tricu

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

76a7e0ddde50e8a600ae8855d9091aa59af3235193605e5a7a07532ae90372af.tri (7962B)

      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 sourceObjectByteWithin value budget = (triage
     99   true
    100   (_ : false)
    101   (bit rest : lazyBool
    102     (_ : lazyBool
    103       (_ : sourceObjectByteOne? bit)
    104       (_ : andLazy? (sourceObjectByteBit? bit) (_ : sourceObjectByteWithin rest (pred_ budget)))
    105       (sourceObjectByteLeaf? rest))
    106     (_ : false)
    107     (not? (isZero_? budget)))
    108   value)
    109 sourceObjectCanonicalByte value = sourceObjectByteWithin value 8
    110 -- This compatibility path must not call base's canonical-only arithmetic.
    111 -- The historical predecessor leaves Stem values unchanged and interprets any
    112 -- non-Leaf bit/tail as truthy. Comparison counts down its finite byte bound;
    113 -- structural equality (not numeric equality) controls the strict endpoint.
    114 sourceObjectReferencePred value = (triage
    115   0
    116   (child : t child)
    117   (bit rest : lazyBool
    118     (_ : matchBool (t t rest) 0 rest)
    119     (_ : t (t t) (sourceObjectReferencePred rest)) bit)
    120   value)
    121 sourceObjectReferenceLte value bound = (lazyBool
    122   (_ : true)
    123   (_ : lazyBool (_ : false)
    124     (_ : sourceObjectReferenceLte (sourceObjectReferencePred value)
    125       (sourceObjectReferencePred bound)) (isZero_? bound))
    126   (isZero_? value))
    127 sourceObjectReferenceLt value bound = (and?
    128   (sourceObjectReferenceLte value bound) (not? (equal? value bound)))
    129 sourceObjectHashByteReference? byte = (or?
    130   (and? (not? (sourceObjectReferenceLt byte 48)) (sourceObjectReferenceLte byte 57))
    131   (and? (not? (sourceObjectReferenceLt byte 97)) (sourceObjectReferenceLte byte 102)))
    132 sourceObjectHashByte? byte = (lazyBool
    133   (_ : N.lowerHex byte)
    134   (_ : sourceObjectHashByteReference? byte)
    135   (sourceObjectCanonicalByte byte))
    136 sourceObjectHashHex bytes = (lazyList
    137   (_ : true)
    138   (byte rest : andLazy? (sourceObjectHashByte? byte) (_ : sourceObjectHashHex rest))
    139   bytes)
    140 sourceObjectHashValid hash =
    141   andLazy? (equal? (length hash) 64)
    142     (_ : sourceObjectHashHex hash)
    143 
    144 sourceObjectVerify domain payload expected =
    145 
    146   onResult_ (sourceObjectDigest domain payload)
    147     (problem : pure (err problem t))
    148     (actual : lazyBool
    149       (_ : pure (ok payload t))
    150       (_ : pure (err "CAS digest mismatch" t))
    151       (equal? actual expected))
    152 
    153 sourceObjectGet root domain hash =
    154   lazyBool
    155     (_ : onResult_ (readFile (sourceObjectPath root hash))
    156       (problem : pure (err problem t))
    157       (payload : sourceObjectVerify domain payload hash))
    158     (_ : pure (err "invalid CAS digest" t))
    159     (sourceObjectHashValid hash)
    160 
    161 sourceObjectStore root domain payload =
    162   onOk_ (sourceObjectDigest domain payload) (hash :
    163     onOk_ (createDirectory root) (_ :
    164       onOk_ (createDirectory (append root "/objects")) (_ :
    165         onOk_ (createDirectory (append root (append "/objects/"
    166           (sourceObjectShard hash)))) (_ :
    167           sourceObjectStoreAt root domain payload hash))))
    168 
    169 -- Host publishes via a unique same-directory temp and an atomic no-replace
    170 -- link; tricu owns the object identity and verifies even a racing winner.
    171 sourceObjectStoreAt root domain payload hash =
    172   onOk_ (writeBytesIfAbsent (sourceObjectPath root hash) payload) (_ :
    173     onResult_ (sourceObjectGet root domain hash)
    174       (problem : pure (err problem t))
    175       (old : lazyBool
    176         (_ : pure (ok hash t))
    177         (_ : pure (err "CAS object exists with different bytes" t))
    178         (equal? old payload)))
    179 
    180 -- tricu owns sharding/directories; the host hashes and atomically transports
    181 -- the inert tree as an indexed DAG, with verified no-replace writes.
    182 sourceObjectPutTree root tree =
    183   onOk_ (hashIndexedTree tree) (hash :
    184     onOk_ (createDirectory root) (_ :
    185       onOk_ (createDirectory (append root "/objects")) (_ :
    186         onOk_ (createDirectory (append root (append "/objects/"
    187           (sourceObjectShard hash)))) (_ :
    188           onOk_ (writeIndexedTreeIfAbsent (sourceObjectPath root hash) hash tree)
    189             (_ : pure (ok hash t))))))
    190 -- Typed verified transport avoids expanding raw executable bytes into a
    191 -- tricu byte list for hashing and decoding. The portable codec stays available
    192 -- as an independent reference; this path does not silently fall back to it.
    193 sourceObjectGetTree root hash =
    194   lazyBool
    195     (_ : readIndexedTree (sourceObjectPath root hash) hash)
    196     (_ : pure (err "invalid CAS digest" t))
    197     (sourceObjectHashValid hash)
    198