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

module Unison.Server.Local.Endpoints.NamespaceListing (serve, NamespaceListingAPI, NamespaceListing (..), NamespaceObject (..), NamedNamespace (..), NamedPatch (..), KindExpression (..)) where

import Data.Aeson
import Data.OpenApi (ToSchema)
import Servant
  ( QueryParam,
    (:>),
  )
import Servant.Docs
  ( DocQueryParam (..),
    ParamKind (Normal),
    ToParam (..),
    ToSample (..),
  )
import Servant.OpenApi ()
import U.Codebase.Branch (NamespaceStats (..))
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.ShortCausalHash (ShortCausalHash)
import Unison.Hash qualified as Hash
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.Server.Backend (Backend)
import Unison.Server.Backend qualified as Backend
import Unison.Server.Types
  ( APIGet,
    HashQualifiedName,
    NamedTerm (..),
    NamedType (..),
    UnisonHash,
    UnisonName,
    v2CausalBranchToUnisonHash,
  )
import Unison.Symbol (Symbol)
import Unison.Syntax.NameSegment qualified as NameSegment
import Unison.Util.Pretty (Width)
import Unison.Var (Var)

type NamespaceListingAPI =
  "list"
    :> QueryParam "relativeTo" Path.Path
    :> QueryParam "namespace" Path.Path
    :> APIGet NamespaceListing

instance ToParam (QueryParam "namespace" Text) where
  toParam :: Proxy (QueryParam "namespace" Text) -> DocQueryParam
toParam Proxy (QueryParam "namespace" Text)
_ =
    String -> [String] -> String -> ParamKind -> DocQueryParam
DocQueryParam
      String
"namespace"
      [String
".", String
".base.List", String
"foo.bar"]
      String
"The fully qualified name of a namespace. The leading `.` is optional."
      ParamKind
Normal

instance ToSample NamespaceListing where
  toSamples :: Proxy NamespaceListing -> [(Text, NamespaceListing)]
toSamples Proxy NamespaceListing
_ =
    [ ( Text
"When no value is provided for `namespace`, the root namespace `.` is "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"listed by default",
        Text -> Text -> [NamespaceObject] -> NamespaceListing
NamespaceListing
          Text
"."
          Text
"#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5"
          [NamedNamespace -> NamespaceObject
Subnamespace (NamedNamespace -> NamespaceObject)
-> NamedNamespace -> NamespaceObject
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Int -> NamedNamespace
NamedNamespace Text
"base" Text
"#19d1o9hi5n642t8jttg" Int
237]
      )
    ]

data NamespaceListing = NamespaceListing
  { NamespaceListing -> Text
namespaceListingFQN :: UnisonName,
    NamespaceListing -> Text
namespaceListingHash :: UnisonHash,
    NamespaceListing -> [NamespaceObject]
namespaceListingChildren :: [NamespaceObject]
  }
  deriving stock ((forall x. NamespaceListing -> Rep NamespaceListing x)
-> (forall x. Rep NamespaceListing x -> NamespaceListing)
-> Generic NamespaceListing
forall x. Rep NamespaceListing x -> NamespaceListing
forall x. NamespaceListing -> Rep NamespaceListing x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NamespaceListing -> Rep NamespaceListing x
from :: forall x. NamespaceListing -> Rep NamespaceListing x
$cto :: forall x. Rep NamespaceListing x -> NamespaceListing
to :: forall x. Rep NamespaceListing x -> NamespaceListing
Generic, Int -> NamespaceListing -> ShowS
[NamespaceListing] -> ShowS
NamespaceListing -> String
(Int -> NamespaceListing -> ShowS)
-> (NamespaceListing -> String)
-> ([NamespaceListing] -> ShowS)
-> Show NamespaceListing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamespaceListing -> ShowS
showsPrec :: Int -> NamespaceListing -> ShowS
$cshow :: NamespaceListing -> String
show :: NamespaceListing -> String
$cshowList :: [NamespaceListing] -> ShowS
showList :: [NamespaceListing] -> ShowS
Show)

instance ToJSON NamespaceListing where
  toJSON :: NamespaceListing -> Value
toJSON NamespaceListing {[NamespaceObject]
Text
$sel:namespaceListingFQN:NamespaceListing :: NamespaceListing -> Text
$sel:namespaceListingHash:NamespaceListing :: NamespaceListing -> Text
$sel:namespaceListingChildren:NamespaceListing :: NamespaceListing -> [NamespaceObject]
namespaceListingFQN :: Text
namespaceListingHash :: Text
namespaceListingChildren :: [NamespaceObject]
..} =
    [Pair] -> Value
object
      [ Key
"namespaceListingFQN" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
namespaceListingFQN,
        Key
"namespaceListingHash" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
namespaceListingHash,
        Key
"namespaceListingChildren" Key -> [NamespaceObject] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [NamespaceObject]
namespaceListingChildren
      ]

instance FromJSON NamespaceListing where
  parseJSON :: Value -> Parser NamespaceListing
parseJSON = String
-> (Object -> Parser NamespaceListing)
-> Value
-> Parser NamespaceListing
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NamespaceListing" ((Object -> Parser NamespaceListing)
 -> Value -> Parser NamespaceListing)
-> (Object -> Parser NamespaceListing)
-> Value
-> Parser NamespaceListing
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
namespaceListingFQN <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"namespaceListingFQN"
    Text
namespaceListingHash <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"namespaceListingHash"
    [NamespaceObject]
namespaceListingChildren <- Object
o Object -> Key -> Parser [NamespaceObject]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"namespaceListingChildren"
    NamespaceListing -> Parser NamespaceListing
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamespaceListing {[NamespaceObject]
Text
$sel:namespaceListingFQN:NamespaceListing :: Text
$sel:namespaceListingHash:NamespaceListing :: Text
$sel:namespaceListingChildren:NamespaceListing :: [NamespaceObject]
namespaceListingFQN :: Text
namespaceListingHash :: Text
namespaceListingChildren :: [NamespaceObject]
..}

deriving instance ToSchema NamespaceListing

data NamespaceObject
  = Subnamespace NamedNamespace
  | TermObject NamedTerm
  | TypeObject NamedType
  | PatchObject NamedPatch
  deriving ((forall x. NamespaceObject -> Rep NamespaceObject x)
-> (forall x. Rep NamespaceObject x -> NamespaceObject)
-> Generic NamespaceObject
forall x. Rep NamespaceObject x -> NamespaceObject
forall x. NamespaceObject -> Rep NamespaceObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NamespaceObject -> Rep NamespaceObject x
from :: forall x. NamespaceObject -> Rep NamespaceObject x
$cto :: forall x. Rep NamespaceObject x -> NamespaceObject
to :: forall x. Rep NamespaceObject x -> NamespaceObject
Generic, Int -> NamespaceObject -> ShowS
[NamespaceObject] -> ShowS
NamespaceObject -> String
(Int -> NamespaceObject -> ShowS)
-> (NamespaceObject -> String)
-> ([NamespaceObject] -> ShowS)
-> Show NamespaceObject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamespaceObject -> ShowS
showsPrec :: Int -> NamespaceObject -> ShowS
$cshow :: NamespaceObject -> String
show :: NamespaceObject -> String
$cshowList :: [NamespaceObject] -> ShowS
showList :: [NamespaceObject] -> ShowS
Show)

instance ToJSON NamespaceObject where
  toJSON :: NamespaceObject -> Value
toJSON = \case
    Subnamespace NamedNamespace
ns -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"Subnamespace", Key
"contents" Key -> NamedNamespace -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NamedNamespace
ns]
    TermObject NamedTerm
t -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TermObject", Key
"contents" Key -> NamedTerm -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NamedTerm
t]
    TypeObject NamedType
t -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"TypeObject", Key
"contents" Key -> NamedType -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NamedType
t]
    PatchObject NamedPatch
p -> [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text -> Value
String Text
"PatchObject", Key
"contents" Key -> NamedPatch -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= NamedPatch
p]

instance FromJSON NamespaceObject where
  parseJSON :: Value -> Parser NamespaceObject
parseJSON = String
-> (Object -> Parser NamespaceObject)
-> Value
-> Parser NamespaceObject
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NamespaceObject" ((Object -> Parser NamespaceObject)
 -> Value -> Parser NamespaceObject)
-> (Object -> Parser NamespaceObject)
-> Value
-> Parser NamespaceObject
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
tag <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    case Text
tag :: Text of
      Text
"Subnamespace" -> NamedNamespace -> NamespaceObject
Subnamespace (NamedNamespace -> NamespaceObject)
-> Parser NamedNamespace -> Parser NamespaceObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser NamedNamespace
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      Text
"TermObject" -> NamedTerm -> NamespaceObject
TermObject (NamedTerm -> NamespaceObject)
-> Parser NamedTerm -> Parser NamespaceObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser NamedTerm
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      Text
"TypeObject" -> NamedType -> NamespaceObject
TypeObject (NamedType -> NamespaceObject)
-> Parser NamedType -> Parser NamespaceObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser NamedType
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      Text
"PatchObject" -> NamedPatch -> NamespaceObject
PatchObject (NamedPatch -> NamespaceObject)
-> Parser NamedPatch -> Parser NamespaceObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser NamedPatch
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents"
      Text
_ -> String -> Parser NamespaceObject
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid NamespaceObject"

deriving instance ToSchema NamespaceObject

data NamedNamespace = NamedNamespace
  { NamedNamespace -> Text
namespaceName :: UnisonName,
    NamedNamespace -> Text
namespaceHash :: UnisonHash,
    NamedNamespace -> Int
namespaceSize :: Int
  }
  deriving ((forall x. NamedNamespace -> Rep NamedNamespace x)
-> (forall x. Rep NamedNamespace x -> NamedNamespace)
-> Generic NamedNamespace
forall x. Rep NamedNamespace x -> NamedNamespace
forall x. NamedNamespace -> Rep NamedNamespace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NamedNamespace -> Rep NamedNamespace x
from :: forall x. NamedNamespace -> Rep NamedNamespace x
$cto :: forall x. Rep NamedNamespace x -> NamedNamespace
to :: forall x. Rep NamedNamespace x -> NamedNamespace
Generic, Int -> NamedNamespace -> ShowS
[NamedNamespace] -> ShowS
NamedNamespace -> String
(Int -> NamedNamespace -> ShowS)
-> (NamedNamespace -> String)
-> ([NamedNamespace] -> ShowS)
-> Show NamedNamespace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamedNamespace -> ShowS
showsPrec :: Int -> NamedNamespace -> ShowS
$cshow :: NamedNamespace -> String
show :: NamedNamespace -> String
$cshowList :: [NamedNamespace] -> ShowS
showList :: [NamedNamespace] -> ShowS
Show)

instance ToJSON NamedNamespace where
  toJSON :: NamedNamespace -> Value
toJSON NamedNamespace {Int
Text
$sel:namespaceName:NamedNamespace :: NamedNamespace -> Text
$sel:namespaceHash:NamedNamespace :: NamedNamespace -> Text
$sel:namespaceSize:NamedNamespace :: NamedNamespace -> Int
namespaceName :: Text
namespaceHash :: Text
namespaceSize :: Int
..} =
    [Pair] -> Value
object
      [ Key
"namespaceName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
namespaceName,
        Key
"namespaceHash" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
namespaceHash,
        Key
"namespaceSize" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Int
namespaceSize
      ]

instance FromJSON NamedNamespace where
  parseJSON :: Value -> Parser NamedNamespace
parseJSON = String
-> (Object -> Parser NamedNamespace)
-> Value
-> Parser NamedNamespace
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NamedNamespace" ((Object -> Parser NamedNamespace)
 -> Value -> Parser NamedNamespace)
-> (Object -> Parser NamedNamespace)
-> Value
-> Parser NamedNamespace
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
namespaceName <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"namespaceName"
    Text
namespaceHash <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"namespaceHash"
    Int
namespaceSize <- Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"namespaceSize"
    NamedNamespace -> Parser NamedNamespace
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedNamespace {Int
Text
$sel:namespaceName:NamedNamespace :: Text
$sel:namespaceHash:NamedNamespace :: Text
$sel:namespaceSize:NamedNamespace :: Int
namespaceName :: Text
namespaceHash :: Text
namespaceSize :: Int
..}

deriving instance ToSchema NamedNamespace

newtype NamedPatch = NamedPatch {NamedPatch -> Text
patchName :: HashQualifiedName}
  deriving stock ((forall x. NamedPatch -> Rep NamedPatch x)
-> (forall x. Rep NamedPatch x -> NamedPatch) -> Generic NamedPatch
forall x. Rep NamedPatch x -> NamedPatch
forall x. NamedPatch -> Rep NamedPatch x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NamedPatch -> Rep NamedPatch x
from :: forall x. NamedPatch -> Rep NamedPatch x
$cto :: forall x. Rep NamedPatch x -> NamedPatch
to :: forall x. Rep NamedPatch x -> NamedPatch
Generic, Int -> NamedPatch -> ShowS
[NamedPatch] -> ShowS
NamedPatch -> String
(Int -> NamedPatch -> ShowS)
-> (NamedPatch -> String)
-> ([NamedPatch] -> ShowS)
-> Show NamedPatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NamedPatch -> ShowS
showsPrec :: Int -> NamedPatch -> ShowS
$cshow :: NamedPatch -> String
show :: NamedPatch -> String
$cshowList :: [NamedPatch] -> ShowS
showList :: [NamedPatch] -> ShowS
Show)
  deriving anyclass (Typeable NamedPatch
Typeable NamedPatch =>
(Proxy NamedPatch -> Declare (Definitions Schema) NamedSchema)
-> ToSchema NamedPatch
Proxy NamedPatch -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy NamedPatch -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy NamedPatch -> Declare (Definitions Schema) NamedSchema
ToSchema)

instance ToJSON NamedPatch where
  toJSON :: NamedPatch -> Value
toJSON NamedPatch {Text
$sel:patchName:NamedPatch :: NamedPatch -> Text
patchName :: Text
..} =
    [Pair] -> Value
object
      [ Key
"patchName" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
patchName
      ]

instance FromJSON NamedPatch where
  parseJSON :: Value -> Parser NamedPatch
parseJSON = String
-> (Object -> Parser NamedPatch) -> Value -> Parser NamedPatch
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NamedPatch" ((Object -> Parser NamedPatch) -> Value -> Parser NamedPatch)
-> (Object -> Parser NamedPatch) -> Value -> Parser NamedPatch
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
patchName <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"patchName"
    NamedPatch -> Parser NamedPatch
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamedPatch {Text
$sel:patchName:NamedPatch :: Text
patchName :: Text
..}

newtype KindExpression = KindExpression {KindExpression -> Text
kindExpressionText :: Text}
  deriving stock ((forall x. KindExpression -> Rep KindExpression x)
-> (forall x. Rep KindExpression x -> KindExpression)
-> Generic KindExpression
forall x. Rep KindExpression x -> KindExpression
forall x. KindExpression -> Rep KindExpression x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KindExpression -> Rep KindExpression x
from :: forall x. KindExpression -> Rep KindExpression x
$cto :: forall x. Rep KindExpression x -> KindExpression
to :: forall x. Rep KindExpression x -> KindExpression
Generic, Int -> KindExpression -> ShowS
[KindExpression] -> ShowS
KindExpression -> String
(Int -> KindExpression -> ShowS)
-> (KindExpression -> String)
-> ([KindExpression] -> ShowS)
-> Show KindExpression
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KindExpression -> ShowS
showsPrec :: Int -> KindExpression -> ShowS
$cshow :: KindExpression -> String
show :: KindExpression -> String
$cshowList :: [KindExpression] -> ShowS
showList :: [KindExpression] -> ShowS
Show)
  deriving anyclass (Typeable KindExpression
Typeable KindExpression =>
(Proxy KindExpression -> Declare (Definitions Schema) NamedSchema)
-> ToSchema KindExpression
Proxy KindExpression -> Declare (Definitions Schema) NamedSchema
forall a.
Typeable a =>
(Proxy a -> Declare (Definitions Schema) NamedSchema) -> ToSchema a
$cdeclareNamedSchema :: Proxy KindExpression -> Declare (Definitions Schema) NamedSchema
declareNamedSchema :: Proxy KindExpression -> Declare (Definitions Schema) NamedSchema
ToSchema)

instance ToJSON KindExpression where
  toJSON :: KindExpression -> Value
toJSON KindExpression {Text
$sel:kindExpressionText:KindExpression :: KindExpression -> Text
kindExpressionText :: Text
..} =
    [Pair] -> Value
object
      [ Key
"kindExpressionText" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
kindExpressionText
      ]

backendListEntryToNamespaceObject ::
  (Var v) =>
  PPE.PrettyPrintEnv ->
  Maybe Width ->
  Backend.ShallowListEntry v a ->
  NamespaceObject
backendListEntryToNamespaceObject :: forall v a.
Var v =>
PrettyPrintEnv
-> Maybe Width -> ShallowListEntry v a -> NamespaceObject
backendListEntryToNamespaceObject PrettyPrintEnv
ppe Maybe Width
typeWidth = \case
  Backend.ShallowTermEntry TermEntry v a
te ->
    NamedTerm -> NamespaceObject
TermObject (NamedTerm -> NamespaceObject) -> NamedTerm -> NamespaceObject
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> Maybe Width -> TermEntry v a -> NamedTerm
forall v a.
Var v =>
PrettyPrintEnv -> Maybe Width -> TermEntry v a -> NamedTerm
Backend.termEntryToNamedTerm PrettyPrintEnv
ppe Maybe Width
typeWidth TermEntry v a
te
  Backend.ShallowTypeEntry TypeEntry
te -> NamedType -> NamespaceObject
TypeObject (NamedType -> NamespaceObject) -> NamedType -> NamespaceObject
forall a b. (a -> b) -> a -> b
$ TypeEntry -> NamedType
Backend.typeEntryToNamedType TypeEntry
te
  Backend.ShallowBranchEntry NameSegment
name CausalHash
hash (NamespaceStats {Int
numContainedTerms :: Int
$sel:numContainedTerms:NamespaceStats :: NamespaceStats -> Int
numContainedTerms, Int
numContainedTypes :: Int
$sel:numContainedTypes:NamespaceStats :: NamespaceStats -> Int
numContainedTypes, Int
numContainedPatches :: Int
$sel:numContainedPatches:NamespaceStats :: NamespaceStats -> Int
numContainedPatches}) ->
    NamedNamespace -> NamespaceObject
Subnamespace (NamedNamespace -> NamespaceObject)
-> NamedNamespace -> NamespaceObject
forall a b. (a -> b) -> a -> b
$
      NamedNamespace
        { $sel:namespaceName:NamedNamespace :: Text
namespaceName = NameSegment -> Text
NameSegment.toEscapedText NameSegment
name,
          $sel:namespaceHash:NamedNamespace :: Text
namespaceHash = Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash -> Text
Hash.toBase32HexText (CausalHash -> Hash
unCausalHash CausalHash
hash),
          $sel:namespaceSize:NamedNamespace :: Int
namespaceSize = Int
numContainedTerms Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numContainedTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numContainedPatches
        }
  Backend.ShallowPatchEntry NameSegment
name ->
    NamedPatch -> NamespaceObject
PatchObject (NamedPatch -> NamespaceObject)
-> (Text -> NamedPatch) -> Text -> NamespaceObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NamedPatch
NamedPatch (Text -> NamespaceObject) -> Text -> NamespaceObject
forall a b. (a -> b) -> a -> b
$ NameSegment -> Text
NameSegment.toEscapedText NameSegment
name

serve ::
  Codebase IO Symbol Ann ->
  Either ShortCausalHash CausalHash ->
  Maybe Path.Path ->
  Maybe Path.Path ->
  Backend.Backend IO NamespaceListing
serve :: Codebase IO Symbol Ann
-> Either ShortCausalHash CausalHash
-> Maybe Path
-> Maybe Path
-> Backend IO NamespaceListing
serve Codebase IO Symbol Ann
codebase Either ShortCausalHash CausalHash
root Maybe Path
mayRelativeTo Maybe Path
mayNamespaceName = do
  CausalBranch Transaction
rootCausal <- (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) (Backend Transaction (CausalBranch Transaction)
 -> Backend IO (CausalBranch Transaction))
-> Backend Transaction (CausalBranch Transaction)
-> Backend IO (CausalBranch Transaction)
forall a b. (a -> b) -> a -> b
$ Either ShortCausalHash CausalHash
-> Backend Transaction (CausalBranch Transaction)
Backend.normaliseRootCausalHash Either ShortCausalHash CausalHash
root

  -- Relative and Listing Path resolution
  --
  -- The full listing path is a combination of the relativeToPath (prefix) and the namespace path
  --
  -- For example:
  --            "base.List"    <>    "Nonempty"
  --                ↑                    ↑
  --         relativeToPath        namespacePath
  --
  -- resulting in "base.List.map" which we can use via the root branch (usually the codebase hash)
  -- to look up the namespace listing and present shallow name, so that the
  -- definition "base.List.Nonempty.map", simple has the name "map"
  --
  let relativeToPath :: Path
relativeToPath = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
Path.empty Maybe Path
mayRelativeTo
  let namespacePath :: Path
namespacePath = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
Path.empty Maybe Path
mayNamespaceName
  let path :: Path
path = Path
relativeToPath Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Path
namespacePath
  (CausalBranch Transaction
listingCausal, Branch Transaction
listingBranch) <-
    (IO (CausalBranch Transaction, Branch Transaction)
-> Backend IO (CausalBranch 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 (IO (CausalBranch Transaction, Branch Transaction)
 -> Backend IO (CausalBranch Transaction, Branch Transaction))
-> (Transaction (CausalBranch Transaction, Branch Transaction)
    -> IO (CausalBranch Transaction, Branch Transaction))
-> Transaction (CausalBranch Transaction, Branch Transaction)
-> Backend IO (CausalBranch Transaction, Branch Transaction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codebase IO Symbol Ann
-> Transaction (CausalBranch Transaction, Branch Transaction)
-> IO (CausalBranch Transaction, Branch Transaction)
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
listingCausal <- Path
-> CausalBranch Transaction
-> Transaction (CausalBranch Transaction)
Codebase.getShallowCausalAtPath Path
path CausalBranch Transaction
rootCausal
      Branch Transaction
listingBranch <- CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
V2Causal.value CausalBranch Transaction
listingCausal
      (CausalBranch Transaction, Branch Transaction)
-> Transaction (CausalBranch Transaction, Branch Transaction)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CausalBranch Transaction
listingCausal, Branch Transaction
listingBranch)
  -- TODO: Currently the ppe is just used to render the types returned from the namespace
  -- listing, which are currently unused because we don't show types in the side-bar.
  -- If we ever show types on hover we need to build and use a proper PPE here, but it's not
  -- shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch
  let shallowPPE :: PrettyPrintEnv
shallowPPE = PrettyPrintEnv
PPE.empty
  let listingFQN :: Text
listingFQN = Path -> Text
Path.toText Path
path
  let listingHash :: Text
listingHash = CausalBranch Transaction -> Text
forall (m :: * -> *). CausalBranch m -> Text
v2CausalBranchToUnisonHash CausalBranch Transaction
listingCausal
  [ShallowListEntry Symbol Ann]
listingEntries <- IO [ShallowListEntry Symbol Ann]
-> Backend IO [ShallowListEntry 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 (Codebase IO Symbol Ann
-> Branch Transaction -> IO [ShallowListEntry Symbol Ann]
forall (m :: * -> *) (n :: * -> *).
MonadIO m =>
Codebase m Symbol Ann
-> Branch n -> m [ShallowListEntry Symbol Ann]
Backend.lsBranch Codebase IO Symbol Ann
codebase Branch Transaction
listingBranch)
  PrettyPrintEnv
-> Text
-> Text
-> [ShallowListEntry Symbol Ann]
-> Backend IO NamespaceListing
forall a.
PrettyPrintEnv
-> Text
-> Text
-> [ShallowListEntry Symbol a]
-> Backend IO NamespaceListing
makeNamespaceListing PrettyPrintEnv
shallowPPE Text
listingFQN Text
listingHash [ShallowListEntry Symbol Ann]
listingEntries

makeNamespaceListing ::
  ( PPE.PrettyPrintEnv ->
    UnisonName ->
    UnisonHash ->
    [Backend.ShallowListEntry Symbol a] ->
    Backend IO NamespaceListing
  )
makeNamespaceListing :: forall a.
PrettyPrintEnv
-> Text
-> Text
-> [ShallowListEntry Symbol a]
-> Backend IO NamespaceListing
makeNamespaceListing PrettyPrintEnv
ppe Text
fqn Text
hash [ShallowListEntry Symbol a]
entries =
  NamespaceListing -> Backend IO NamespaceListing
forall a. a -> Backend IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamespaceListing -> Backend IO NamespaceListing)
-> ([NamespaceObject] -> NamespaceListing)
-> [NamespaceObject]
-> Backend IO NamespaceListing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [NamespaceObject] -> NamespaceListing
NamespaceListing Text
fqn Text
hash ([NamespaceObject] -> Backend IO NamespaceListing)
-> [NamespaceObject] -> Backend IO NamespaceListing
forall a b. (a -> b) -> a -> b
$
    (ShallowListEntry Symbol a -> NamespaceObject)
-> [ShallowListEntry Symbol a] -> [NamespaceObject]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (PrettyPrintEnv
-> Maybe Width -> ShallowListEntry Symbol a -> NamespaceObject
forall v a.
Var v =>
PrettyPrintEnv
-> Maybe Width -> ShallowListEntry v a -> NamespaceObject
backendListEntryToNamespaceObject PrettyPrintEnv
ppe Maybe Width
forall a. Maybe a
Nothing)
      [ShallowListEntry Symbol a]
entries