{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Unison.Server.Local.Endpoints.NamespaceDetails where

import Data.Set qualified as Set
import Servant (Capture, QueryParam, (:>))
import Servant.Docs (DocCapture (..), ToCapture (..))
import Servant.OpenApi ()
import U.Codebase.Causal qualified as V2Causal
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.Runtime qualified as Rt
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.Server.Backend
import Unison.Server.Backend qualified as Backend
import Unison.Server.Doc qualified as Doc
import Unison.Server.Types
  ( APIGet,
    NamespaceDetails (..),
    v2CausalBranchToUnisonHash,
  )
import Unison.Symbol (Symbol)
import Unison.Util.Pretty (Width)

type NamespaceDetailsAPI =
  "namespaces"
    :> Capture "namespace" Path.Path
    :> QueryParam "renderWidth" Width
    :> APIGet NamespaceDetails

instance ToCapture (Capture "namespace" Text) where
  toCapture :: Proxy (Capture "namespace" Text) -> DocCapture
toCapture Proxy (Capture "namespace" Text)
_ =
    String -> String -> DocCapture
DocCapture
      String
"namespace"
      String
"The fully qualified name of a namespace. The leading `.` is optional."

namespaceDetails ::
  Rt.Runtime Symbol ->
  Codebase IO Symbol Ann ->
  Path.Path ->
  Either ShortCausalHash CausalHash ->
  Maybe Width ->
  Backend IO NamespaceDetails
namespaceDetails :: Runtime Symbol
-> Codebase IO Symbol Ann
-> Path
-> Either ShortCausalHash CausalHash
-> Maybe Width
-> Backend IO NamespaceDetails
namespaceDetails Runtime Symbol
runtime Codebase IO Symbol Ann
codebase Path
namespacePath Either ShortCausalHash CausalHash
root Maybe Width
_mayWidth = do
  (CausalBranch Transaction
rootCausal, CausalBranch Transaction
namespaceCausal, Branch Transaction
shallowBranch) <-
    (forall x. Transaction x -> IO x)
-> Backend
     Transaction
     (CausalBranch Transaction, CausalBranch Transaction,
      Branch Transaction)
-> Backend
     IO
     (CausalBranch Transaction, CausalBranch Transaction,
      Branch 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
      CausalBranch Transaction
rootCausalHash <-
        case Either ShortCausalHash CausalHash
root of
          (Left ShortCausalHash
sch) -> ShortCausalHash -> Backend Transaction (CausalBranch Transaction)
Backend.resolveRootBranchHashV2 ShortCausalHash
sch
          (Right CausalHash
ch) -> Transaction (CausalBranch Transaction)
-> Backend Transaction (CausalBranch Transaction)
forall (m :: * -> *) a. Monad m => m a -> Backend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (CausalBranch Transaction)
 -> Backend Transaction (CausalBranch Transaction))
-> Transaction (CausalBranch Transaction)
-> Backend Transaction (CausalBranch Transaction)
forall a b. (a -> b) -> a -> b
$ CausalHash -> Transaction (CausalBranch Transaction)
Codebase.expectCausalBranchByCausalHash CausalHash
ch
      CausalBranch Transaction
namespaceCausal <- Transaction (CausalBranch Transaction)
-> Backend Transaction (CausalBranch Transaction)
forall (m :: * -> *) a. Monad m => m a -> Backend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (CausalBranch Transaction)
 -> Backend Transaction (CausalBranch Transaction))
-> Transaction (CausalBranch Transaction)
-> Backend Transaction (CausalBranch Transaction)
forall a b. (a -> b) -> a -> b
$ Path
-> CausalBranch Transaction
-> Transaction (CausalBranch Transaction)
Codebase.getShallowCausalAtPath Path
namespacePath CausalBranch Transaction
rootCausalHash
      Branch Transaction
shallowBranch <- Transaction (Branch Transaction)
-> Backend Transaction (Branch Transaction)
forall (m :: * -> *) a. Monad m => m a -> Backend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (Branch Transaction)
 -> Backend Transaction (Branch Transaction))
-> Transaction (Branch Transaction)
-> Backend Transaction (Branch Transaction)
forall a b. (a -> b) -> a -> b
$ CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
V2Causal.value CausalBranch Transaction
namespaceCausal
      (CausalBranch Transaction, CausalBranch Transaction,
 Branch Transaction)
-> Backend
     Transaction
     (CausalBranch Transaction, CausalBranch Transaction,
      Branch Transaction)
forall a. a -> Backend Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CausalBranch Transaction
rootCausalHash, CausalBranch Transaction
namespaceCausal, Branch Transaction
shallowBranch)
  NamespaceDetails
namespaceDetails <- do
    (Names
_localNamesOnly, 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
rootCausal Path
namespacePath
    let mayReadmeRef :: Maybe TermReference
mayReadmeRef = Set NameSegment -> Branch Transaction -> Maybe TermReference
forall (m :: * -> *).
Set NameSegment -> Branch m -> Maybe TermReference
Backend.findDocInBranch Set NameSegment
readmeNames Branch Transaction
shallowBranch
    Maybe Doc
renderedReadme <- Maybe TermReference
-> (TermReference -> Backend IO Doc) -> Backend IO (Maybe Doc)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe TermReference
mayReadmeRef \TermReference
readmeRef -> do
      -- Local server currently ignores eval errors.
      (EvaluatedDoc Symbol
eDoc, [Error]
_evalErrs) <- IO (EvaluatedDoc Symbol, [Error])
-> Backend IO (EvaluatedDoc Symbol, [Error])
forall a. IO a -> Backend IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvaluatedDoc Symbol, [Error])
 -> Backend IO (EvaluatedDoc Symbol, [Error]))
-> IO (EvaluatedDoc Symbol, [Error])
-> Backend IO (EvaluatedDoc Symbol, [Error])
forall a b. (a -> b) -> a -> b
$ Runtime Symbol
-> Codebase IO Symbol Ann
-> TermReference
-> IO (EvaluatedDoc Symbol, [Error])
evalDocRef Runtime Symbol
runtime Codebase IO Symbol Ann
codebase TermReference
readmeRef
      Doc -> Backend IO Doc
forall a. a -> Backend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Backend IO Doc) -> Doc -> Backend IO Doc
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnvDecl -> EvaluatedDoc Symbol -> Doc
forall v. Var v => PrettyPrintEnvDecl -> EvaluatedDoc v -> Doc
Doc.renderDoc PrettyPrintEnvDecl
ppe EvaluatedDoc Symbol
eDoc
    let causalHash :: Text
causalHash = CausalBranch Transaction -> Text
forall (m :: * -> *). CausalBranch m -> Text
v2CausalBranchToUnisonHash CausalBranch Transaction
namespaceCausal
    NamespaceDetails -> Backend IO NamespaceDetails
forall a. a -> Backend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamespaceDetails -> Backend IO NamespaceDetails)
-> NamespaceDetails -> Backend IO NamespaceDetails
forall a b. (a -> b) -> a -> b
$ Path -> Text -> Maybe Doc -> NamespaceDetails
NamespaceDetails Path
namespacePath Text
causalHash Maybe Doc
renderedReadme
  NamespaceDetails -> Backend IO NamespaceDetails
forall a. a -> Backend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamespaceDetails -> Backend IO NamespaceDetails)
-> NamespaceDetails -> Backend IO NamespaceDetails
forall a b. (a -> b) -> a -> b
$ NamespaceDetails
namespaceDetails
  where
    readmeNames :: Set NameSegment
readmeNames =
      [NameSegment] -> Set NameSegment
forall a. Ord a => [a] -> Set a
Set.fromList ([NameSegment] -> Set NameSegment)
-> [NameSegment] -> Set NameSegment
forall a b. (a -> b) -> a -> b
$ Text -> NameSegment
NameSegment (Text -> NameSegment) -> [Text] -> [NameSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text
"README", Text
"Readme", Text
"ReadMe", Text
"readme"]