{-# 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"
    -- Optional name to include in summary.
    -- It's propagated through to the response as-is.
    -- If missing, the short hash will be used instead.
    :> 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"
    -- Optional name to include in summary.
    -- It's propagated through to the response as-is.
    -- If missing, the short hash will be used instead.
    :> 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