tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

79cd7f19d3de74be38bac823d8674f6b74327a4ae12bb0cf405119b51fbd9ea5.tri (8330B)

      1 !import prelude *
      2 !import io *
      3 !import native_math as N
      4 !export sourceObjectTreeDomain
      5 !export sourceObjectFlatTreeDomain
      6 !export sourceObjectManifestDomain
      7 !export sourceObjectTreeAbi
      8 !export sourceObjectTreeKind
      9 !export sourceObjectEncodeOnto
     10 !export sourceObjectEncode
     11 !export sourceObjectDecode
     12 !export sourceObjectDecodeComplete
     13 !export sourceObjectShard
     14 !export sourceObjectPath
     15 !export sourceObjectDigest
     16 !export sourceObjectHashHex
     17 !export sourceObjectHashValid
     18 !export sourceObjectVerify
     19 !export sourceObjectGet
     20 !export sourceObjectStoreAt
     21 !export sourceObjectStore
     22 !export sourceObjectPutTree
     23 !export sourceObjectGetTree
     24 
     25 -- Native executable objects preserve sharing as name-neutral indexed bundles.
     26 -- The flat codec below remains an independent data codec with its own domain;
     27 -- it is not the native executable publication format.
     28 sourceObjectTreeDomain = "arboricx.indexed-tree.v1"
     29 sourceObjectFlatTreeDomain = "arboricx.tree-term.v1"
     30 sourceObjectManifestDomain = "arboricx.module-manifest.v1"
     31 sourceObjectTreeAbi = "arboricx.abi.tree.v1"
     32 sourceObjectTreeKind = "arboricx.indexed-tree.v1"
     33 
     34 -- Build directly onto a suffix. Appending each encoded left subtree copies
     35 -- its byte list once per enclosing fork and retains huge intermediate lists
     36 -- for compiler exports. This visits each expanded tree occurrence once.
     37 -- Keep triage as the small shape eliminator; canonical preorder is unchanged.
     38 sourceObjectEncodeOnto tree suffix =
     39   triage
     40     (pair 0 suffix)
     41     (child : pair 1 (sourceObjectEncodeOnto child suffix))
     42     (left right : pair 2 (sourceObjectEncodeOnto left (sourceObjectEncodeOnto right suffix)))
     43     tree
     44 sourceObjectEncode tree = sourceObjectEncodeOnto tree t
     45 
     46 sourceObjectDecode bytes =
     47   lazyList
     48     (_ : err "truncated tree-term" bytes)
     49     (tag rest :
     50       lazyBool
     51         (_ : ok t rest)
     52         (_ : lazyBool
     53           (_ : lazyResult
     54             (problem remaining : err problem remaining)
     55             (child remaining : ok (t child) remaining)
     56             (sourceObjectDecode rest))
     57           (_ : lazyBool
     58             (_ : lazyResult
     59               (problem remaining : err problem remaining)
     60               (left remaining : lazyResult
     61                 (problem tail : err problem tail)
     62                 (right tail : ok (t left right) tail)
     63                 (sourceObjectDecode remaining))
     64               (sourceObjectDecode rest))
     65             (_ : err "invalid tree-term tag" rest)
     66             (equal? tag 2))
     67           (equal? tag 1))
     68         (equal? tag 0))
     69     bytes
     70 
     71 sourceObjectDecodeComplete bytes =
     72   lazyResult
     73     (problem remaining : err problem remaining)
     74     (tree remaining : lazyList
     75       (_ : ok tree t)
     76       (_ _ : err "trailing tree-term bytes" t)
     77       remaining)
     78     (sourceObjectDecode bytes)
     79 
     80 -- The shard is taken by finite destructuring: it must not cause recursion
     81 -- over an abstract hash during fresh-store normalization.
     82 sourceObjectShard hash =
     83   matchList t (a r0 :
     84     matchList t (b r1 :
     85       matchList t (c _ : pair a (pair b (pair c t))) r1) r0) hash
     86 sourceObjectPath root hash =
     87   append root (append "/objects/" (append (sourceObjectShard hash)
     88     (append "/" hash)))
     89 sourceObjectDigest domain payload =
     90   sha256Hex (append domain (pair 0 payload))
     91 
     92 -- Native math assumes canonical naturals. Keep the existing behavior for
     93 -- arbitrary trees: only canonical bytes use the binary comparison fast path.
     94 -- Canonical-byte helpers stay private; malformed trees retain the reference path.
     95 sourceObjectByteLeaf? value = triage true (_ : false) (_ _ : false) value
     96 sourceObjectByteBit? value = triage true (child : sourceObjectByteLeaf? child) (_ _ : false) value
     97 sourceObjectByteOne? value = triage false (child : sourceObjectByteLeaf? child) (_ _ : false) value
     98 -- Eight statically bounded structural steps avoid numeric countdown work for
     99 -- every digest byte. Inspect the rest shape before the bit, as in the bounded
    100 -- recognizer; an invalid bit or exhausted bound must not force deeper fields.
    101 sourceObjectByteStep next value = (triage
    102   true
    103   (_ : false)
    104   (bit rest : lazyBool
    105     (_ : sourceObjectByteOne? bit)
    106     (_ : andLazy? (sourceObjectByteBit? bit) (_ : next rest))
    107     (sourceObjectByteLeaf? rest))
    108   value)
    109 sourceObjectCanonicalByte value = (sourceObjectByteStep
    110   (sourceObjectByteStep
    111     (sourceObjectByteStep
    112       (sourceObjectByteStep
    113         (sourceObjectByteStep
    114           (sourceObjectByteStep
    115             (sourceObjectByteStep
    116               (sourceObjectByteStep sourceObjectByteLeaf?)))))))
    117   value)
    118 -- This compatibility path must not call base's canonical-only arithmetic.
    119 -- The historical predecessor leaves Stem values unchanged and interprets any
    120 -- non-Leaf bit/tail as truthy. Comparison counts down its finite byte bound;
    121 -- structural equality (not numeric equality) controls the strict endpoint.
    122 sourceObjectReferencePred value = (triage
    123   0
    124   (child : t child)
    125   (bit rest : lazyBool
    126     (_ : matchBool (t t rest) 0 rest)
    127     (_ : t (t t) (sourceObjectReferencePred rest)) bit)
    128   value)
    129 sourceObjectReferenceLte value bound = (lazyBool
    130   (_ : true)
    131   (_ : lazyBool (_ : false)
    132     (_ : sourceObjectReferenceLte (sourceObjectReferencePred value)
    133       (sourceObjectReferencePred bound)) (isZero_? bound))
    134   (isZero_? value))
    135 sourceObjectReferenceLt value bound = (and?
    136   (sourceObjectReferenceLte value bound) (not? (equal? value bound)))
    137 sourceObjectHashByteReference? byte = (or?
    138   (and? (not? (sourceObjectReferenceLt byte 48)) (sourceObjectReferenceLte byte 57))
    139   (and? (not? (sourceObjectReferenceLt byte 97)) (sourceObjectReferenceLte byte 102)))
    140 sourceObjectHashByte? byte = (lazyBool
    141   (_ : N.lowerHex byte)
    142   (_ : sourceObjectHashByteReference? byte)
    143   (sourceObjectCanonicalByte byte))
    144 sourceObjectHashHex bytes = (lazyList
    145   (_ : true)
    146   (byte rest : andLazy? (sourceObjectHashByte? byte) (_ : sourceObjectHashHex rest))
    147   bytes)
    148 sourceObjectHashValid hash =
    149   andLazy? (equal? (length hash) 64)
    150     (_ : sourceObjectHashHex hash)
    151 
    152 sourceObjectVerify domain payload expected =
    153 
    154   onResult_ (sourceObjectDigest domain payload)
    155     (problem : pure (err problem t))
    156     (actual : lazyBool
    157       (_ : pure (ok payload t))
    158       (_ : pure (err "CAS digest mismatch" t))
    159       (equal? actual expected))
    160 
    161 sourceObjectGet root domain hash =
    162   lazyBool
    163     (_ : onResult_ (readFile (sourceObjectPath root hash))
    164       (problem : pure (err problem t))
    165       (payload : sourceObjectVerify domain payload hash))
    166     (_ : pure (err "invalid CAS digest" t))
    167     (sourceObjectHashValid hash)
    168 
    169 sourceObjectStore root domain payload =
    170   onOk_ (sourceObjectDigest domain payload) (hash :
    171     onOk_ (createDirectory root) (_ :
    172       onOk_ (createDirectory (append root "/objects")) (_ :
    173         onOk_ (createDirectory (append root (append "/objects/"
    174           (sourceObjectShard hash)))) (_ :
    175           sourceObjectStoreAt root domain payload hash))))
    176 
    177 -- Host publishes via a unique same-directory temp and an atomic no-replace
    178 -- link; tricu owns the object identity and verifies even a racing winner.
    179 sourceObjectStoreAt root domain payload hash =
    180   onOk_ (writeBytesIfAbsent (sourceObjectPath root hash) payload) (_ :
    181     onResult_ (sourceObjectGet root domain hash)
    182       (problem : pure (err problem t))
    183       (old : lazyBool
    184         (_ : pure (ok hash t))
    185         (_ : pure (err "CAS object exists with different bytes" t))
    186         (equal? old payload)))
    187 
    188 -- tricu owns sharding/directories; the host hashes and atomically transports
    189 -- the inert tree as an indexed DAG, with verified no-replace writes.
    190 sourceObjectPutTree root tree =
    191   onOk_ (hashIndexedTree tree) (hash :
    192     onOk_ (createDirectory root) (_ :
    193       onOk_ (createDirectory (append root "/objects")) (_ :
    194         onOk_ (createDirectory (append root (append "/objects/"
    195           (sourceObjectShard hash)))) (_ :
    196           onOk_ (writeIndexedTreeIfAbsent (sourceObjectPath root hash) hash tree)
    197             (_ : pure (ok hash t))))))
    198 -- Typed verified transport avoids expanding raw executable bytes into a
    199 -- tricu byte list for hashing and decoding. The portable codec stays available
    200 -- as an independent reference; this path does not silently fall back to it.
    201 sourceObjectGetTree root hash =
    202   lazyBool
    203     (_ : readIndexedTree (sourceObjectPath root hash) hash)
    204     (_ : pure (err "invalid CAS digest" t))
    205     (sourceObjectHashValid hash)
    206