{-# 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
    TextDocumentIdentifier
textDocument <- Object
v Object -> Key -> Parser TextDocumentIdentifier
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"textDocument"
    Position
position <- Object
v Object -> Key -> Parser Position
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"position"
    OpenOnShareParams -> Parser OpenOnShareParams
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OpenOnShareParams {TextDocumentIdentifier
$sel:textDocument:OpenOnShareParams :: TextDocumentIdentifier
textDocument :: TextDocumentIdentifier
textDocument, Position
$sel:position:OpenOnShareParams :: Position
position :: Position
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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
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.ResponseError Aeson.Value -> Lsp ()) ->
  Lsp ()
openOnShareHandler :: forall {f :: MessageDirection}.
TRequestMessage ('Method_CustomMethod "unison/openOnShare")
-> (Either ResponseError Value -> Lsp ()) -> Lsp ()
openOnShareHandler TRequestMessage ('Method_CustomMethod "unison/openOnShare")
m Either ResponseError Value -> Lsp ()
respond = do
  Either Text ()
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
    ProjectPath
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 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
    ProjectAndBranch ProjectName
remoteProjectName ProjectBranchName
remoteBranchName <- Text
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> ExceptT
     Text Lsp (ProjectAndBranch ProjectName ProjectBranchName)
forall a. Text -> Lsp (Maybe a) -> ExceptT Text Lsp a
orFail Text
"No Share project found, have you pushed or pulled it yet?" (Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
 -> ExceptT
      Text Lsp (ProjectAndBranch ProjectName ProjectBranchName))
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
-> ExceptT
     Text Lsp (ProjectAndBranch ProjectName ProjectBranchName)
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> ProjectPath
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
forall v a.
Codebase IO v a
-> ProjectPath
-> Lsp (Maybe (ProjectAndBranch ProjectName ProjectBranchName))
resolveRemoteProjectBranch Codebase IO Symbol Ann
codebase ProjectPath
pp
    let paramsJSON :: Value
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 {TextDocumentIdentifier
$sel:textDocument:OpenOnShareParams :: OpenOnShareParams -> TextDocumentIdentifier
textDocument :: TextDocumentIdentifier
textDocument, Position
$sel:position:OpenOnShareParams :: OpenOnShareParams -> Position
position :: Position
position} <- case Value -> Result OpenOnShareParams
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
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
    LabeledDependency
ref <- Text
-> Lsp (Maybe LabeledDependency)
-> ExceptT Text Lsp LabeledDependency
forall a. Text -> Lsp (Maybe a) -> ExceptT Text Lsp a
orFail Text
"Error: Can only open top-level definitions." (Lsp (Maybe LabeledDependency)
 -> ExceptT Text Lsp LabeledDependency)
-> (MaybeT Lsp LabeledDependency -> Lsp (Maybe LabeledDependency))
-> MaybeT Lsp LabeledDependency
-> ExceptT Text Lsp LabeledDependency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT Lsp LabeledDependency -> Lsp (Maybe LabeledDependency)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Lsp LabeledDependency
 -> ExceptT Text Lsp LabeledDependency)
-> MaybeT Lsp LabeledDependency
-> ExceptT Text Lsp LabeledDependency
forall a b. (a -> b) -> a -> b
$ Uri -> Position -> MaybeT Lsp LabeledDependency
forall (m :: * -> *).
Lspish m =>
Uri -> Position -> MaybeT m LabeledDependency
LSPQ.refAtPosition TextDocumentIdentifier
textDocument._uri Position
position

    -- Get the FQN for the reference
    PrettyPrintEnvDecl
pped <- Lsp PrettyPrintEnvDecl -> ExceptT Text Lsp PrettyPrintEnvDecl
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 PrettyPrintEnvDecl -> ExceptT Text Lsp PrettyPrintEnvDecl)
-> Lsp PrettyPrintEnvDecl -> ExceptT Text Lsp PrettyPrintEnvDecl
forall a b. (a -> b) -> a -> b
$ Uri -> Lsp PrettyPrintEnvDecl
forall (m :: * -> *). Lspish m => Uri -> m PrettyPrintEnvDecl
ppedForFile TextDocumentIdentifier
textDocument._uri
    let unsuffixifiedPPE :: PrettyPrintEnv
unsuffixifiedPPE = PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.unsuffixifiedPPE PrettyPrintEnvDecl
pped
    let (HashQualified Name
fqn, Text
kind) = case LabeledDependency
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 :: Text
fqnText = HashQualified Name -> Text
SyntaxHQ.toText HashQualified Name
fqn

    let shareUrl :: String
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
    ExceptT Text Lsp Bool -> ExceptT Text Lsp ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Text Lsp Bool -> ExceptT Text Lsp ())
-> (IO Bool -> ExceptT Text Lsp Bool)
-> IO Bool
-> ExceptT Text Lsp ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> ExceptT Text Lsp Bool
forall a. IO a -> ExceptT Text Lsp a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT Text Lsp ()) -> IO Bool -> ExceptT Text Lsp ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
Web.openBrowser String
shareUrl

  -- Send the response
  case Either Text ()
result of
    (Left Text
errMsg) -> Either ResponseError Value -> Lsp ()
respond (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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 ResponseError Value -> Lsp ()
respond (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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
      Maybe a
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 Maybe a
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