{-# LANGUAGE DataKinds #-}

module Unison.LSP.OpenOnShare
  ( openOnShareHandler,
  )
where

import Control.Lens hiding (List)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson qualified as Aeson
import Data.Text qualified as Text
import Language.LSP.Protocol.Lens qualified as LSP
import Language.LSP.Protocol.Message qualified as Msg
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Types qualified as LSP
import U.Codebase.Sqlite.Project
import U.Codebase.Sqlite.ProjectBranch
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.ProjectPath
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Core.Project (ProjectBranchName, ProjectName (..))
import Unison.LSP.FileAnalysis (ppedForFile)
import Unison.LSP.Queries qualified as LSPQ
import Unison.LSP.Types
import Unison.LabeledDependency qualified as LD
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Syntax.HashQualified qualified as SyntaxHQ
import Web.Browser qualified as Web

data OpenOnShareParams = OpenOnShareParams
  { OpenOnShareParams -> TextDocumentIdentifier
textDocument :: LSP.TextDocumentIdentifier,
    OpenOnShareParams -> Position
position :: LSP.Position
  }
  deriving (Int -> OpenOnShareParams -> ShowS
[OpenOnShareParams] -> ShowS
OpenOnShareParams -> String
(Int -> OpenOnShareParams -> ShowS)
-> (OpenOnShareParams -> String)
-> ([OpenOnShareParams] -> ShowS)
-> Show OpenOnShareParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenOnShareParams -> ShowS
showsPrec :: Int -> OpenOnShareParams -> ShowS
$cshow :: OpenOnShareParams -> String
show :: OpenOnShareParams -> String
$cshowList :: [OpenOnShareParams] -> ShowS
showList :: [OpenOnShareParams] -> ShowS
Show, OpenOnShareParams -> OpenOnShareParams -> Bool
(OpenOnShareParams -> OpenOnShareParams -> Bool)
-> (OpenOnShareParams -> OpenOnShareParams -> Bool)
-> Eq OpenOnShareParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenOnShareParams -> OpenOnShareParams -> Bool
== :: OpenOnShareParams -> OpenOnShareParams -> Bool
$c/= :: OpenOnShareParams -> OpenOnShareParams -> Bool
/= :: OpenOnShareParams -> OpenOnShareParams -> Bool
Eq)

instance Aeson.FromJSON OpenOnShareParams where
  parseJSON :: Value -> Parser OpenOnShareParams
parseJSON = String
-> (Object -> Parser OpenOnShareParams)
-> Value
-> Parser OpenOnShareParams
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"OpenOnShareParams" ((Object -> Parser OpenOnShareParams)
 -> Value -> Parser OpenOnShareParams)
-> (Object -> Parser OpenOnShareParams)
-> Value
-> Parser OpenOnShareParams
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    textDocument <- Object
v Object -> Key -> Parser TextDocumentIdentifier
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"textDocument"
    position <- v Aeson..: "position"
    pure OpenOnShareParams {textDocument, position}

data OpenOnShareResponse = OpenOnShareResponse
  { OpenOnShareResponse -> Maybe Text
error :: Maybe Text
  }
  deriving (Int -> OpenOnShareResponse -> ShowS
[OpenOnShareResponse] -> ShowS
OpenOnShareResponse -> String
(Int -> OpenOnShareResponse -> ShowS)
-> (OpenOnShareResponse -> String)
-> ([OpenOnShareResponse] -> ShowS)
-> Show OpenOnShareResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenOnShareResponse -> ShowS
showsPrec :: Int -> OpenOnShareResponse -> ShowS
$cshow :: OpenOnShareResponse -> String
show :: OpenOnShareResponse -> String
$cshowList :: [OpenOnShareResponse] -> ShowS
showList :: [OpenOnShareResponse] -> ShowS
Show, OpenOnShareResponse -> OpenOnShareResponse -> Bool
(OpenOnShareResponse -> OpenOnShareResponse -> Bool)
-> (OpenOnShareResponse -> OpenOnShareResponse -> Bool)
-> Eq OpenOnShareResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenOnShareResponse -> OpenOnShareResponse -> Bool
== :: OpenOnShareResponse -> OpenOnShareResponse -> Bool
$c/= :: OpenOnShareResponse -> OpenOnShareResponse -> Bool
/= :: OpenOnShareResponse -> OpenOnShareResponse -> Bool
Eq)

instance Aeson.ToJSON OpenOnShareResponse where
  toJSON :: OpenOnShareResponse -> Value
toJSON (OpenOnShareResponse Maybe Text
err) =
    [Pair] -> Value
Aeson.object
      [ Key
"error" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Maybe Text
err
      ]

-- | Handler for the 'unison/openOnShare' custom LSP request.
-- This resolves the symbol at the given position to its FQN and makes an HTTP POST
-- to the local Share service.
openOnShareHandler ::
  Msg.TRequestMessage ('Msg.Method_CustomMethod "unison/openOnShare") ->
  (Either (Msg.TResponseError ('Msg.Method_CustomMethod "unison/openOnShare")) Aeson.Value -> Lsp ()) ->
  Lsp ()
openOnShareHandler :: forall {f :: MessageDirection} {f :: MessageDirection}.
TRequestMessage ('Method_CustomMethod "unison/openOnShare")
-> (Either
      (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
    -> Lsp ())
-> Lsp ()
openOnShareHandler TRequestMessage ('Method_CustomMethod "unison/openOnShare")
m Either
  (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
-> Lsp ()
respond = do
  result <- ExceptT Text Lsp () -> Lsp (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text Lsp () -> Lsp (Either Text ()))
-> ExceptT Text Lsp () -> Lsp (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
    pp <- Lsp ProjectPath -> ExceptT Text Lsp ProjectPath
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 ProjectPath
forall (m :: * -> *). Lspish m => m ProjectPath
getCurrentProjectPath
    Env {codebase} <- ask
    ProjectAndBranch remoteProjectName remoteBranchName <- orFail "No Share project found, have you pushed or pulled it yet?" $ resolveRemoteProjectBranch codebase pp
    let paramsJSON = TRequestMessage ('Method_CustomMethod "unison/openOnShare")
m TRequestMessage ('Method_CustomMethod "unison/openOnShare")
-> Getting
     Value
     (TRequestMessage ('Method_CustomMethod "unison/openOnShare"))
     Value
-> Value
forall s a. s -> Getting a s a -> a
^. Getting
  Value
  (TRequestMessage ('Method_CustomMethod "unison/openOnShare"))
  Value
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage ('Method_CustomMethod "unison/openOnShare")) Value
LSP.params
    OpenOnShareParams {textDocument, position} <- case Aeson.fromJSON paramsJSON of
      Aeson.Error String
err -> Text -> ExceptT Text Lsp OpenOnShareParams
forall a. Text -> ExceptT Text Lsp a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text Lsp OpenOnShareParams)
-> Text -> ExceptT Text Lsp OpenOnShareParams
forall a b. (a -> b) -> a -> b
$ Text
"Invalid parameters: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
      Aeson.Success OpenOnShareParams
p -> OpenOnShareParams -> ExceptT Text Lsp OpenOnShareParams
forall a. a -> ExceptT Text Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OpenOnShareParams
p

    -- Get the symbol reference at the position
    ref <- orFail "Error: Definition not found in Codebase" . runMaybeT $ LSPQ.refAtPosition textDocument._uri position

    -- Get the FQN for the reference
    pped <- lift $ ppedForFile textDocument._uri
    let unsuffixifiedPPE = PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.unsuffixifiedPPE PrettyPrintEnvDecl
pped
    let (fqn, kind) = case ref of
          LD.TypeReference TypeReference
typeRef -> (PrettyPrintEnv -> TypeReference -> HashQualified Name
PPE.typeName PrettyPrintEnv
unsuffixifiedPPE TypeReference
typeRef, Text
"types")
          LD.TermReferent Referent
termRef -> (PrettyPrintEnv -> Referent -> HashQualified Name
PPE.termName PrettyPrintEnv
unsuffixifiedPPE Referent
termRef, Text
"terms")
    let fqnText = HashQualified Name -> Text
SyntaxHQ.toText HashQualified Name
fqn

    let shareUrl =
          Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            Text
"https://share.unison-lang.org/"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text ProjectName
remoteProjectName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/code/"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @Text ProjectBranchName
remoteBranchName
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/latest/"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
kind
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"." Text
"/" Text
fqnText
    void . liftIO $ Web.openBrowser shareUrl

  -- Send the response
  case result of
    (Left Text
errMsg) -> Either
  (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
-> Lsp ()
respond (Value
-> Either
     (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
forall a b. b -> Either a b
Right (Value
 -> Either
      (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value)
-> Value
-> Either
     (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
forall a b. (a -> b) -> a -> b
$ OpenOnShareResponse -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (OpenOnShareResponse -> Value) -> OpenOnShareResponse -> Value
forall a b. (a -> b) -> a -> b
$ Maybe Text -> OpenOnShareResponse
OpenOnShareResponse (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
errMsg))
    Either Text ()
_ -> Either
  (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
-> Lsp ()
respond (Value
-> Either
     (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
forall a b. b -> Either a b
Right (Value
 -> Either
      (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value)
-> Value
-> Either
     (TResponseError ('Method_CustomMethod "unison/openOnShare")) Value
forall a b. (a -> b) -> a -> b
$ OpenOnShareResponse -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (OpenOnShareResponse -> Value) -> OpenOnShareResponse -> Value
forall a b. (a -> b) -> a -> b
$ Maybe Text -> OpenOnShareResponse
OpenOnShareResponse Maybe Text
forall a. Maybe a
Nothing)
  where
    orFail :: Text -> Lsp (Maybe a) -> ExceptT Text Lsp a
    orFail :: forall a. Text -> Lsp (Maybe a) -> ExceptT Text Lsp a
orFail Text
err Lsp (Maybe a)
action = do
      ma <- Lsp (Maybe a) -> ExceptT Text Lsp (Maybe a)
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 (Maybe a)
action
      case ma of
        Just a
a -> a -> ExceptT Text Lsp a
forall a. a -> ExceptT Text Lsp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Maybe a
Nothing -> Text -> ExceptT Text Lsp a
forall a. Text -> ExceptT Text Lsp a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
err

resolveRemoteProjectBranch :: Codebase IO v a -> PP.ProjectPath -> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
resolveRemoteProjectBranch :: forall v a.
Codebase IO v a
-> ProjectPath
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
resolveRemoteProjectBranch Codebase IO v a
codebase ProjectPath
pp = do
  IO (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
forall a. IO a -> Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
 -> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName)))
-> IO (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
forall a b. (a -> b) -> a -> b
$ Codebase IO v a
-> Transaction
     (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> IO (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO v a
codebase (Transaction
   (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
 -> IO (Maybe (ProjectAndBranch ProjectName ProjectBranchName)))
-> Transaction
     (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> IO (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
forall a b. (a -> b) -> a -> b
$ do
    let ids :: ProjectAndBranch ProjectId ProjectBranchId
ids = (ProjectId
-> ProjectBranchId -> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectPath
pp.project.projectId ProjectPath
pp.branch.branchId)
    ProjectAndBranch ProjectId ProjectBranchId
-> URI
-> Transaction
     (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
Q.resolveRemoteProjectBranchNames ProjectAndBranch ProjectId ProjectBranchId
ids URI
Share.hardCodedUri