tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

Indexed.hs (1960B)

      1 -- Name-neutral indexed object codec, shared by import, loading and publication.
      2 module ContentStore.Indexed
      3   ( indexedTreeDomain, encodeIndexedTree, decodeIndexedTree, decodeIndexedSnapshot ) where
      4 
      5 import ContentStore.Snapshot (Snapshot)
      6 import ContentStore.Object
      7 import Runtime (T)
      8 import Wire
      9 import Data.ByteString (ByteString)
     10 import qualified Data.Vector as V
     11 
     12 -- A single name-neutral root in the existing indexed Arboricx wire format.
     13 -- This is a distinct object kind, not a new encoding under tree-term hashes.
     14 indexedTreeDomain :: Domain
     15 indexedTreeDomain = Domain "arboricx.indexed-tree.v1"
     16 
     17 -- The same name-neutral canonical object emitted by indexed bundle import.
     18 -- Preserve sharing before serialization, without applying the supplied tree.
     19 encodeIndexedTree :: T -> IO ByteString
     20 encodeIndexedTree tree = encodeBundle <$> buildBundleShared [("root", tree)]
     21 
     22 decodeIndexedTree :: ByteString -> Either String T
     23 decodeIndexedTree payload = do
     24   bundle <- decodeBundle payload
     25   decodeIndexedBundle bundle
     26 
     27 -- Metadata limits are caller policy; the returned tree still occupies memory
     28 -- proportional to its indexed DAG. This operation does not evaluate the tree.
     29 decodeIndexedSnapshot :: Int -> Int -> Snapshot -> IO (Either String T)
     30 decodeIndexedSnapshot sections metadata snapshot = do
     31   decoded <- decodeBundleSnapshot sections metadata snapshot
     32   pure (decoded >>= decodeIndexedBundle)
     33 
     34 decodeIndexedBundle :: Bundle -> Either String T
     35 decodeIndexedBundle bundle = do
     36   verifyBundle bundle
     37   root <- case (bundleRoots bundle, manifestExports $ bundleManifest bundle) of
     38     ([index], [exported])
     39       | exportName exported == "root" && exportRoot exported == index
     40       , exportKind exported == "term", exportAbi exported == "arboricx.abi.tree.v1" -> Right index
     41     _ -> Left "indexed tree requires one root named root with the tree ABI"
     42   let terms = reconstructBundleTerms (bundleNodes bundle)
     43   pure (terms V.! fromIntegral root)
     44