{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
module Unison.Server.Local.Endpoints.DefinitionSummary
( TermSummaryAPI,
serveTermSummary,
TermSummary (..),
TypeSummaryAPI,
serveTypeSummary,
TypeSummary (..),
)
where
import Control.Monad.Reader
import Servant (Capture, QueryParam, (:>))
import Servant.OpenApi ()
import U.Codebase.HashTags (CausalHash)
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Server.Backend (Backend)
import Unison.Server.Backend qualified as Backend
import Unison.Server.Types
( APIGet,
TermSummary (..),
TypeSummary (..),
mayDefaultWidth,
)
import Unison.Symbol (Symbol)
import Unison.Util.Pretty (Width)
type TermSummaryAPI =
"definitions"
:> "terms"
:> "by-hash"
:> Capture "hash" Referent
:> "summary"
:> QueryParam "name" Name
:> QueryParam "relativeTo" Path.Path
:> QueryParam "renderWidth" Width
:> APIGet TermSummary
serveTermSummary ::
Codebase IO Symbol Ann ->
Referent ->
Maybe Name ->
Either ShortCausalHash CausalHash ->
Maybe Path.Path ->
Maybe Width ->
Backend IO TermSummary
serveTermSummary :: Codebase IO Symbol Ann
-> Referent
-> Maybe Name
-> Either ShortCausalHash CausalHash
-> Maybe Path
-> Maybe Width
-> Backend IO TermSummary
serveTermSummary Codebase IO Symbol Ann
codebase Referent
referent Maybe Name
mayName Either ShortCausalHash CausalHash
root Maybe Path
relativeTo Maybe Width
mayWidth = do
let relativeToPath :: Path
relativeToPath = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
forall a. Monoid a => a
mempty Maybe Path
relativeTo
CausalBranch Transaction
root <- (forall x. Transaction x -> IO x)
-> Backend Transaction (CausalBranch Transaction)
-> Backend IO (CausalBranch Transaction)
forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> Backend m a -> Backend n a
Backend.hoistBackend (Codebase IO Symbol Ann -> Transaction x -> IO x
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase) do
Either ShortCausalHash CausalHash
-> Backend Transaction (CausalBranch Transaction)
Backend.normaliseRootCausalHash Either ShortCausalHash CausalHash
root
(Names
_, PrettyPrintEnvDecl
ppe) <- Codebase IO Symbol Ann
-> CausalBranch Transaction
-> Path
-> Backend IO (Names, PrettyPrintEnvDecl)
forall (m :: * -> *) (n :: * -> *) v a.
MonadIO m =>
Codebase m v a
-> CausalBranch n -> Path -> Backend m (Names, PrettyPrintEnvDecl)
Backend.namesAtPathFromRootBranchHash Codebase IO Symbol Ann
codebase CausalBranch Transaction
root Path
relativeToPath
let mkPPED :: Set LabeledDependency -> Transaction PrettyPrintEnvDecl
mkPPED Set LabeledDependency
_deps = PrettyPrintEnvDecl -> Transaction PrettyPrintEnvDecl
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrettyPrintEnvDecl
ppe
Codebase IO Symbol Ann
-> Referent
-> Maybe Name
-> (Set LabeledDependency -> Transaction PrettyPrintEnvDecl)
-> Maybe Width
-> Backend IO TermSummary
Backend.termSummaryForReferent Codebase IO Symbol Ann
codebase Referent
referent Maybe Name
mayName Set LabeledDependency -> Transaction PrettyPrintEnvDecl
mkPPED Maybe Width
mayWidth
type TypeSummaryAPI =
"definitions"
:> "types"
:> "by-hash"
:> Capture "hash" Reference
:> "summary"
:> QueryParam "name" Name
:> QueryParam "relativeTo" Path.Path
:> QueryParam "renderWidth" Width
:> APIGet TypeSummary
serveTypeSummary ::
Codebase IO Symbol Ann ->
Reference ->
Maybe Name ->
Either ShortCausalHash CausalHash ->
Maybe Path.Path ->
Maybe Width ->
Backend IO TypeSummary
serveTypeSummary :: Codebase IO Symbol Ann
-> Reference
-> Maybe Name
-> Either ShortCausalHash CausalHash
-> Maybe Path
-> Maybe Width
-> Backend IO TypeSummary
serveTypeSummary Codebase IO Symbol Ann
codebase Reference
reference Maybe Name
mayName Either ShortCausalHash CausalHash
_mayRoot Maybe Path
_relativeTo Maybe Width
mayWidth = do
let shortHash :: ShortHash
shortHash = Reference -> ShortHash
Reference.toShortHash Reference
reference
let displayName :: HashQualified Name
displayName = HashQualified Name
-> (Name -> HashQualified Name) -> Maybe Name -> HashQualified Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ShortHash -> HashQualified Name
forall n. ShortHash -> HashQualified n
HQ.HashOnly ShortHash
shortHash) Name -> HashQualified Name
forall n. n -> HashQualified n
HQ.NameOnly Maybe Name
mayName
(TypeTag
tag, DisplayObject () (Decl Symbol Ann)
displayDecl) <-
IO (TypeTag, DisplayObject () (Decl Symbol Ann))
-> Backend IO (TypeTag, DisplayObject () (Decl Symbol Ann))
forall (m :: * -> *) a. Monad m => m a -> Backend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
Codebase IO Symbol Ann
-> Transaction (TypeTag, DisplayObject () (Decl Symbol Ann))
-> IO (TypeTag, DisplayObject () (Decl Symbol Ann))
forall (m :: * -> *) v a b.
MonadIO m =>
Codebase m v a -> Transaction b -> m b
Codebase.runTransaction Codebase IO Symbol Ann
codebase do
TypeTag
tag <- Codebase IO Symbol Ann -> Reference -> Transaction TypeTag
forall v (m :: * -> *).
Var v =>
Codebase m v Ann -> Reference -> Transaction TypeTag
Backend.getTypeTag Codebase IO Symbol Ann
codebase Reference
reference
DisplayObject () (Decl Symbol Ann)
displayDecl <- Codebase IO Symbol Ann
-> Reference -> Transaction (DisplayObject () (Decl Symbol Ann))
forall (m :: * -> *).
Codebase m Symbol Ann
-> Reference -> Transaction (DisplayObject () (Decl Symbol Ann))
Backend.displayType Codebase IO Symbol Ann
codebase Reference
reference
(TypeTag, DisplayObject () (Decl Symbol Ann))
-> Transaction (TypeTag, DisplayObject () (Decl Symbol Ann))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeTag
tag, DisplayObject () (Decl Symbol Ann)
displayDecl)
let syntaxHeader :: DisplayObject SyntaxText SyntaxText
syntaxHeader = Width
-> HashQualified Name
-> DisplayObject () (Decl Symbol Ann)
-> DisplayObject SyntaxText SyntaxText
Backend.typeToSyntaxHeader Width
width HashQualified Name
displayName DisplayObject () (Decl Symbol Ann)
displayDecl
TypeSummary -> Backend IO TypeSummary
forall a. a -> Backend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeSummary -> Backend IO TypeSummary)
-> TypeSummary -> Backend IO TypeSummary
forall a b. (a -> b) -> a -> b
$
TypeSummary
{ $sel:displayName:TypeSummary :: HashQualified Name
displayName = HashQualified Name
displayName,
$sel:hash:TypeSummary :: ShortHash
hash = ShortHash
shortHash,
$sel:summary:TypeSummary :: DisplayObject SyntaxText SyntaxText
summary = (SyntaxText -> SyntaxText)
-> (SyntaxText -> SyntaxText)
-> DisplayObject SyntaxText SyntaxText
-> DisplayObject SyntaxText SyntaxText
forall a b c d.
(a -> b) -> (c -> d) -> DisplayObject a c -> DisplayObject b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap SyntaxText -> SyntaxText
forall (g :: * -> *).
Functor g =>
g (Element Reference) -> g Element
Backend.mungeSyntaxText SyntaxText -> SyntaxText
forall (g :: * -> *).
Functor g =>
g (Element Reference) -> g Element
Backend.mungeSyntaxText DisplayObject SyntaxText SyntaxText
syntaxHeader,
$sel:tag:TypeSummary :: TypeTag
tag = TypeTag
tag
}
where
width :: Width
width = Maybe Width -> Width
mayDefaultWidth Maybe Width
mayWidth