module Unison.Codebase.Editor.HandleInput.UI (openUI) where

import Control.Lens qualified as Lens
import Control.Monad.Reader (ask)
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import U.Codebase.Branch.Type qualified as V2Branch
import U.Codebase.Reference qualified as V2 (Reference)
import U.Codebase.Referent qualified as V2 (Referent)
import U.Codebase.Referent qualified as V2.Referent
import U.Codebase.Sqlite.Project qualified as Project
import U.Codebase.Sqlite.ProjectBranch qualified as ProjectBranch
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
import Unison.ConstructorType qualified as ConstructorType
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Parser.Ann (Ann (..))
import Unison.Prelude
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
import Unison.Referent qualified as Referent
import Unison.Server.CodebaseServer qualified as Server
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Web.Browser (openBrowser)

openUI :: Path.Path' -> Cli ()
openUI :: Path' -> Cli ()
openUI Path'
path' = do
  Cli.Env {Maybe BaseUrl
serverBaseUrl :: Maybe BaseUrl
$sel:serverBaseUrl:Env :: Env -> Maybe BaseUrl
serverBaseUrl} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  ProjectPath
defnPath <- Path' -> Cli ProjectPath
Cli.resolvePath' Path'
path'
  ProjectPath
pp <- Cli ProjectPath
Cli.getCurrentProjectPath
  Maybe BaseUrl -> (BaseUrl -> Cli ()) -> Cli ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe BaseUrl
serverBaseUrl \BaseUrl
url -> do
    BaseUrl -> ProjectPath -> Absolute -> Cli ()
openUIForProject BaseUrl
url ProjectPath
pp (ProjectPath
defnPath ProjectPath -> Getting Absolute ProjectPath Absolute -> Absolute
forall s a. s -> Getting a s a -> a
^. Getting Absolute ProjectPath Absolute
forall p b (f :: * -> *).
Functor f =>
(Absolute -> f Absolute)
-> ProjectPathG p b -> f (ProjectPathG p b)
PP.absPath_)

openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli ()
openUIForProject :: BaseUrl -> ProjectPath -> Absolute -> Cli ()
openUIForProject BaseUrl
url pp :: ProjectPath
pp@(PP.ProjectPath Project
project ProjectBranch
projectBranch Absolute
perspective) Absolute
defnPath = do
  Maybe DefinitionReference
mayDefinitionRef <- Absolute -> Cli (Maybe DefinitionReference)
getDefinitionRef Absolute
perspective
  let projectBranchNames :: ProjectAndBranch ProjectName ProjectBranchName
projectBranchNames = (Project -> ProjectName)
-> (ProjectBranch -> ProjectBranchName)
-> ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b c d.
(a -> b)
-> (c -> d) -> ProjectAndBranch a c -> ProjectAndBranch b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Project -> ProjectName
Project.name ProjectBranch -> ProjectBranchName
ProjectBranch.name (Project -> ProjectBranch -> ProjectAndBranch Project ProjectBranch
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Project
project ProjectBranch
projectBranch)
  Bool
_success <- IO Bool -> Cli Bool
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Cli Bool) -> (Text -> IO Bool) -> Text -> Cli Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
openBrowser (String -> IO Bool) -> (Text -> String) -> Text -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> Cli Bool) -> Text -> Cli Bool
forall a b. (a -> b) -> a -> b
$ Service -> BaseUrl -> Text
Server.urlFor (ProjectAndBranch ProjectName ProjectBranchName
-> Absolute -> Maybe DefinitionReference -> Service
Server.ProjectBranchUI ProjectAndBranch ProjectName ProjectBranchName
projectBranchNames Absolute
perspective Maybe DefinitionReference
mayDefinitionRef) BaseUrl
url
  pure ()
  where
    -- If the provided ui path matches a definition, find it.
    getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference))
    getDefinitionRef :: Absolute -> Cli (Maybe DefinitionReference)
getDefinitionRef Absolute
perspective = MaybeT Cli DefinitionReference -> Cli (Maybe DefinitionReference)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Cli DefinitionReference -> Cli (Maybe DefinitionReference))
-> MaybeT Cli DefinitionReference
-> Cli (Maybe DefinitionReference)
forall a b. (a -> b) -> a -> b
$ do
      Cli.Env {Codebase IO Symbol Ann
codebase :: Codebase IO Symbol Ann
$sel:codebase:Env :: Env -> Codebase IO Symbol Ann
codebase} <- Cli Env -> MaybeT Cli Env
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      (Absolute
pathToDefinitionNamespace, NameSegment
_nameSeg) <- Maybe (Absolute, NameSegment) -> MaybeT Cli (Absolute, NameSegment)
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe (Absolute, NameSegment)
 -> MaybeT Cli (Absolute, NameSegment))
-> Maybe (Absolute, NameSegment)
-> MaybeT Cli (Absolute, NameSegment)
forall a b. (a -> b) -> a -> b
$ Absolute -> Maybe (Absolute, NameSegment)
forall s a. Snoc s s a a => s -> Maybe (s, a)
Lens.unsnoc Absolute
defnPath
      let defnNamespaceProjectPath :: ProjectPath
defnNamespaceProjectPath = ProjectPath
pp ProjectPath -> (ProjectPath -> ProjectPath) -> ProjectPath
forall a b. a -> (a -> b) -> b
& (Absolute -> Identity Absolute)
-> ProjectPath -> Identity ProjectPath
forall p b (f :: * -> *).
Functor f =>
(Absolute -> f Absolute)
-> ProjectPathG p b -> f (ProjectPathG p b)
PP.absPath_ ((Absolute -> Identity Absolute)
 -> ProjectPath -> Identity ProjectPath)
-> Absolute -> ProjectPath -> ProjectPath
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Absolute
pathToDefinitionNamespace
      Branch Transaction
namespaceBranch <- Cli (Branch Transaction) -> MaybeT Cli (Branch Transaction)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Cli (Branch Transaction) -> MaybeT Cli (Branch Transaction))
-> (Transaction (Branch Transaction) -> Cli (Branch Transaction))
-> Transaction (Branch Transaction)
-> MaybeT Cli (Branch Transaction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction (Branch Transaction) -> Cli (Branch Transaction)
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction (Branch Transaction)
 -> MaybeT Cli (Branch Transaction))
-> Transaction (Branch Transaction)
-> MaybeT Cli (Branch Transaction)
forall a b. (a -> b) -> a -> b
$ ProjectPath -> Transaction (Branch Transaction)
Codebase.getShallowBranchAtProjectPath ProjectPath
defnNamespaceProjectPath
      Name
fqn <- Maybe Name -> MaybeT Cli Name
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe Name -> MaybeT Cli Name) -> Maybe Name -> MaybeT Cli Name
forall a b. (a -> b) -> a -> b
$ do
        [NameSegment]
pathFromPerspective <- [NameSegment] -> [NameSegment] -> Maybe [NameSegment]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix (Path -> [NameSegment]
Path.toList (Absolute -> Path
Path.unabsolute Absolute
perspective)) (Path -> [NameSegment]
Path.toList (Path -> [NameSegment]) -> Path -> [NameSegment]
forall a b. (a -> b) -> a -> b
$ Absolute -> Path
Path.unabsolute Absolute
defnPath)
        Path -> Maybe Name
Path.toName (Path -> Maybe Name)
-> ([NameSegment] -> Path) -> [NameSegment] -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Path
Path.fromList ([NameSegment] -> Maybe Name) -> [NameSegment] -> Maybe Name
forall a b. (a -> b) -> a -> b
$ [NameSegment]
pathFromPerspective
      DefinitionReference
def <- Cli (Maybe DefinitionReference) -> MaybeT Cli DefinitionReference
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Cli (Maybe DefinitionReference) -> MaybeT Cli DefinitionReference)
-> Cli (Maybe DefinitionReference)
-> MaybeT Cli DefinitionReference
forall a b. (a -> b) -> a -> b
$ Codebase IO Symbol Ann
-> Branch Transaction -> Name -> Cli (Maybe DefinitionReference)
forall (m :: * -> *) (n :: * -> *).
Codebase m Symbol Ann
-> Branch n -> Name -> Cli (Maybe DefinitionReference)
getTermOrTypeRef Codebase IO Symbol Ann
codebase Branch Transaction
namespaceBranch Name
fqn
      pure DefinitionReference
def

getTermOrTypeRef :: Codebase m Symbol Ann -> V2Branch.Branch n -> Name -> Cli (Maybe Server.DefinitionReference)
getTermOrTypeRef :: forall (m :: * -> *) (n :: * -> *).
Codebase m Symbol Ann
-> Branch n -> Name -> Cli (Maybe DefinitionReference)
getTermOrTypeRef Codebase m Symbol Ann
codebase Branch n
namespaceBranch Name
fqn = MaybeT Cli DefinitionReference -> Cli (Maybe DefinitionReference)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Cli DefinitionReference -> Cli (Maybe DefinitionReference))
-> MaybeT Cli DefinitionReference
-> Cli (Maybe DefinitionReference)
forall a b. (a -> b) -> a -> b
$ do
  let nameSeg :: NameSegment
nameSeg = Name -> NameSegment
Name.lastSegment Name
fqn
  let terms :: MaybeT Cli DefinitionReference
terms = do
        Map Referent (n MdValues)
matchingTerms <- Maybe (Map Referent (n MdValues))
-> MaybeT Cli (Map Referent (n MdValues))
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe (Map Referent (n MdValues))
 -> MaybeT Cli (Map Referent (n MdValues)))
-> Maybe (Map Referent (n MdValues))
-> MaybeT Cli (Map Referent (n MdValues))
forall a b. (a -> b) -> a -> b
$ NameSegment
-> Map NameSegment (Map Referent (n MdValues))
-> Maybe (Map Referent (n MdValues))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
nameSeg (Branch n -> Map NameSegment (Map Referent (n MdValues))
forall (m :: * -> *).
Branch m -> Map NameSegment (Map Referent (m MdValues))
V2Branch.terms Branch n
namespaceBranch)
        Referent
oneTerm <- Maybe Referent -> MaybeT Cli Referent
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe Referent -> MaybeT Cli Referent)
-> Maybe Referent -> MaybeT Cli Referent
forall a b. (a -> b) -> a -> b
$ Set Referent -> Maybe Referent
forall a. Set a -> Maybe a
Set.lookupMin (Set Referent -> Maybe Referent) -> Set Referent -> Maybe Referent
forall a b. (a -> b) -> a -> b
$ Map Referent (n MdValues) -> Set Referent
forall k a. Map k a -> Set k
Map.keysSet Map Referent (n MdValues)
matchingTerms
        Cli DefinitionReference -> MaybeT Cli DefinitionReference
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Cli DefinitionReference -> MaybeT Cli DefinitionReference)
-> Cli DefinitionReference -> MaybeT Cli DefinitionReference
forall a b. (a -> b) -> a -> b
$ Transaction DefinitionReference -> Cli DefinitionReference
forall a. Transaction a -> Cli a
Cli.runTransaction (Codebase m Symbol Ann
-> Name -> Referent -> Transaction DefinitionReference
forall (m :: * -> *).
Codebase m Symbol Ann
-> Name -> Referent -> Transaction DefinitionReference
toTermReference Codebase m Symbol Ann
codebase Name
fqn Referent
oneTerm)
  let types :: MaybeT Cli DefinitionReference
types = do
        Map Reference (n MdValues)
matchingTypes <- Maybe (Map Reference (n MdValues))
-> MaybeT Cli (Map Reference (n MdValues))
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe (Map Reference (n MdValues))
 -> MaybeT Cli (Map Reference (n MdValues)))
-> Maybe (Map Reference (n MdValues))
-> MaybeT Cli (Map Reference (n MdValues))
forall a b. (a -> b) -> a -> b
$ NameSegment
-> Map NameSegment (Map Reference (n MdValues))
-> Maybe (Map Reference (n MdValues))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
nameSeg (Branch n -> Map NameSegment (Map Reference (n MdValues))
forall (m :: * -> *).
Branch m -> Map NameSegment (Map Reference (m MdValues))
V2Branch.types Branch n
namespaceBranch)
        Reference
oneType <- Maybe Reference -> MaybeT Cli Reference
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe Reference -> MaybeT Cli Reference)
-> Maybe Reference -> MaybeT Cli Reference
forall a b. (a -> b) -> a -> b
$ Set Reference -> Maybe Reference
forall a. Set a -> Maybe a
Set.lookupMin (Set Reference -> Maybe Reference)
-> Set Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ Map Reference (n MdValues) -> Set Reference
forall k a. Map k a -> Set k
Map.keysSet Map Reference (n MdValues)
matchingTypes
        pure (Name -> Reference -> DefinitionReference
toTypeReference Name
fqn Reference
oneType)
  MaybeT Cli DefinitionReference
terms MaybeT Cli DefinitionReference
-> MaybeT Cli DefinitionReference -> MaybeT Cli DefinitionReference
forall a. MaybeT Cli a -> MaybeT Cli a -> MaybeT Cli a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT Cli DefinitionReference
types

toTypeReference :: Name -> V2.Reference -> Server.DefinitionReference
toTypeReference :: Name -> Reference -> DefinitionReference
toTypeReference Name
name Reference
reference =
  HashQualified Name -> DefinitionReference
Server.TypeReference (HashQualified Name -> DefinitionReference)
-> HashQualified Name -> DefinitionReference
forall a b. (a -> b) -> a -> b
$
    Name -> Reference -> HashQualified Name
forall n. n -> Reference -> HashQualified n
HQ.fromNamedReference Name
name (Reference -> Reference
Conversions.reference2to1 Reference
reference)

toTermReference :: Codebase m Symbol Ann -> Name -> V2.Referent -> Sqlite.Transaction Server.DefinitionReference
toTermReference :: forall (m :: * -> *).
Codebase m Symbol Ann
-> Name -> Referent -> Transaction DefinitionReference
toTermReference Codebase m Symbol Ann
codebase Name
name Referent
referent = do
  case Referent
referent of
    V2.Referent.Ref Reference
reference ->
      DefinitionReference -> Transaction DefinitionReference
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefinitionReference -> Transaction DefinitionReference)
-> DefinitionReference -> Transaction DefinitionReference
forall a b. (a -> b) -> a -> b
$
        HashQualified Name -> DefinitionReference
Server.TermReference (HashQualified Name -> DefinitionReference)
-> HashQualified Name -> DefinitionReference
forall a b. (a -> b) -> a -> b
$
          Name -> Reference -> HashQualified Name
forall n. n -> Reference -> HashQualified n
HQ.fromNamedReference Name
name (Reference -> Reference
Conversions.reference2to1 Reference
reference)
    V2.Referent.Con Reference
_ ConstructorId
_ -> do
      Referent
v1Referent <- (Reference -> Transaction ConstructorType)
-> Referent -> Transaction Referent
forall (m :: * -> *).
Applicative m =>
(Reference -> m ConstructorType) -> Referent -> m Referent
Conversions.referent2to1 (Codebase m Symbol Ann -> Reference -> Transaction ConstructorType
forall (m :: * -> *) v a.
Codebase m v a -> Reference -> Transaction ConstructorType
Codebase.getDeclType Codebase m Symbol Ann
codebase) Referent
referent
      let hq :: HashQualified Name
hq = Name -> Referent -> HashQualified Name
forall n. n -> Referent -> HashQualified n
HQ.fromNamedReferent Name
name Referent
v1Referent

      DefinitionReference -> Transaction DefinitionReference
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case Referent
v1Referent of
        Referent.Con ConstructorReference
_ ConstructorType
ConstructorType.Data ->
          HashQualified Name -> DefinitionReference
Server.DataConstructorReference HashQualified Name
hq
        Referent.Con ConstructorReference
_ ConstructorType
ConstructorType.Effect ->
          HashQualified Name -> DefinitionReference
Server.AbilityConstructorReference HashQualified Name
hq
        Referent.Ref Reference
_ -> String -> DefinitionReference
forall a. HasCallStack => String -> a
error String
"Impossible! *twirls mustache*"