bundle.tri (8075B)
1 !import prelude * 2 !import io * 3 !import source_object * 4 !import source_module * 5 !import source_resolve * 6 !export * 7 8 -- Indexed Arboricx v1.1 writer. The host only supplies binary writes; 9 -- tricu constructs the node DAG, canonical manifest and complete bundle. 10 -- Natural numbers use a little-endian bit tree. Consume its bits first, 11 -- rather than subtracting 256 repeatedly when encoding large offsets. 12 sourceBundleTakeByte number places weight byte = 13 triage 14 (pair byte 0) 15 (_ : pair byte 0) 16 (bit rest : 17 lazyBool 18 (_ : pair (add byte (matchBool weight 0 bit)) rest) 19 (_ : sourceBundleTakeByte rest (pred places) (add weight weight) 20 (add byte (matchBool weight 0 bit))) 21 (equal? places 1)) 22 number 23 sourceBundleSplitByte number = sourceBundleTakeByte number 8 1 0 24 sourceBundleU32 number = 25 matchPair (b0 n1 : 26 matchPair (b1 n2 : 27 matchPair (b2 n3 : 28 matchPair (b3 n4 : pair b3 (pair b2 (pair b1 (pair b0 t)))) 29 (sourceBundleSplitByte n3)) 30 (sourceBundleSplitByte n2)) 31 (sourceBundleSplitByte n1)) 32 (sourceBundleSplitByte number) 33 sourceBundleU64 number = 34 matchPair (b0 n1 : 35 matchPair (b1 n2 : 36 matchPair (b2 n3 : 37 matchPair (b3 n4 : 38 matchPair (b4 n5 : 39 matchPair (b5 n6 : 40 matchPair (b6 n7 : 41 matchPair (b7 n8 : 42 [(b7) (b6) (b5) (b4) (b3) (b2) (b1) (b0)]) 43 (sourceBundleSplitByte n7)) 44 (sourceBundleSplitByte n6)) 45 (sourceBundleSplitByte n5)) 46 (sourceBundleSplitByte n4)) 47 (sourceBundleSplitByte n3)) 48 (sourceBundleSplitByte n2)) 49 (sourceBundleSplitByte n1)) 50 (sourceBundleSplitByte number) 51 sourceBundleText text = append (sourceBundleU32 (length text)) text 52 53 -- An index-key has the same Leaf/Stem/Fork shape as its corresponding node, 54 -- with child indices (not subtrees) in the child positions. The association 55 -- list deduplicates structural keys across *all* exports, in left-to-right 56 -- postorder, matching Wire.buildBundle. 57 -- State: (nextIndex, (reversedIndexedNodes, seenKeyToIndex)). 58 sourceBundleAdd key state = 59 lazyMaybe 60 (_ : pair (fst state) 61 (pair (succ (fst state)) 62 (pair (pair key (fst (snd state))) 63 (pair (pair key (fst state)) (snd (snd state)))))) 64 (oldIndex : pair oldIndex state) 65 (sourceFindExternal (snd (snd state)) key) 66 sourceBundleVisit tree state = 67 triage 68 (sourceBundleAdd t state) 69 (child : matchPair (index next : sourceBundleAdd (t index) next) 70 (sourceBundleVisit child state)) 71 (left right : matchPair (leftIndex next : 72 matchPair (rightIndex after : 73 sourceBundleAdd (t leftIndex rightIndex) after) 74 (sourceBundleVisit right next)) 75 (sourceBundleVisit left state)) 76 tree 77 sourceBundleIndexExports exports state roots = 78 lazyList 79 (_ : pair (reverse roots) (reverse (fst (snd state)))) 80 (entry rest : matchPair (index after : 81 sourceBundleIndexExports rest after (pair (pair (fst entry) index) roots)) 82 (sourceBundleVisit (snd entry) state)) 83 exports 84 sourceBundleIndex namedTrees = 85 sourceBundleIndexExports namedTrees (pair 0 (pair t t)) t 86 87 sourceBundlePayload key = 88 triage 89 [(0)] 90 (child : pair 1 (sourceBundleU32 child)) 91 (left right : pair 2 (append (sourceBundleU32 left) 92 (sourceBundleU32 right))) 93 key 94 sourceBundleNodeEntry key = 95 triage 96 (append (sourceBundleU32 1) (sourceBundlePayload key)) 97 (_ : append (sourceBundleU32 5) (sourceBundlePayload key)) 98 (_ _ : append (sourceBundleU32 9) (sourceBundlePayload key)) 99 key 100 sourceBundleNodeEntries nodes = 101 lazyList 102 (_ : t) 103 (key rest : append (sourceBundleNodeEntry key) (sourceBundleNodeEntries rest)) 104 nodes 105 sourceBundleNodes nodes = 106 append (sourceBundleU64 (length nodes)) (sourceBundleNodeEntries nodes) 107 108 sourceBundleRootEntry root first = 109 append (sourceBundleU32 (snd root)) 110 (sourceBundleText (matchBool "default" "root" first)) 111 sourceBundleRootEntries roots first = 112 lazyList 113 (_ : t) 114 (root rest : append (sourceBundleRootEntry root first) 115 (sourceBundleRootEntries rest false)) 116 roots 117 sourceBundleExportEntry root = 118 append (sourceBundleText (fst root)) 119 (append (sourceBundleU32 (snd root)) 120 (append (sourceBundleText "term") 121 (sourceBundleText "arboricx.abi.tree.v1"))) 122 sourceBundleExportEntries roots = 123 lazyList 124 (_ : t) 125 (root rest : append (sourceBundleExportEntry root) (sourceBundleExportEntries rest)) 126 roots 127 sourceBundleManifest roots = 128 append "ARBMNFST" (append [(0) (1) (0) (1)] 129 (append (sourceBundleText "arboricx.bundle.manifest.v1") 130 (append (sourceBundleText "tree-calculus-executable-object") 131 (append (sourceBundleText "tree-calculus.v1") 132 (append (sourceBundleText "indexed") 133 (append (sourceBundleText "arboricx.indexed.node.v1") 134 (append (sourceBundleText "arboricx.indexed.payload.v1") 135 (append (sourceBundleText "tree-calculus.v1") 136 (append (sourceBundleText "normal-order") 137 (append (sourceBundleText "arboricx.abi.tree.v1") 138 (append (sourceBundleU32 0) 139 (append [(0)] 140 (append (sourceBundleU32 (length roots)) 141 (append (sourceBundleRootEntries roots true) 142 (append (sourceBundleU32 (length roots)) 143 (append (sourceBundleExportEntries roots) 144 (append (sourceBundleU32 1) 145 (append [(0) (5) (0) (0) (0) (8)] 146 (append "arboricx" (sourceBundleU32 0)))))))))))))))))))) 147 sourceBundleSection section offset size = 148 append (sourceBundleU32 section) 149 (append [(0) (1) (0) (1) (0) (0) (0) (0)] 150 (append (sourceBundleU64 offset) 151 (append (sourceBundleU64 size) (sourceBundleU32 0)))) 152 sourceBundleHeader = 153 append "ARBORICX" (append [(0) (1) (0) (0)] 154 (append (sourceBundleU32 2) 155 (append (sourceBundleU64 0) (sourceBundleU64 32)))) 156 -- Complete the variable-length sections before exposing their lengths to 157 -- fixed-width integer encoders; forcing an abstract `length` as bits can 158 -- otherwise drive unbounded normalization of an unknown stream. 159 sourceBundleCountFrom bytes count = 160 lazyList 161 (_ : ok count t) 162 (_ rest : sourceBundleCountFrom rest (succ count)) 163 bytes 164 sourceBundleCount bytes = sourceBundleCountFrom bytes 0 165 sourceBundleAssemble manifest nodes = 166 lazyResult 167 (_ _ : t) 168 (manifestSize _ : lazyResult 169 (_ _ : t) 170 (nodesSize _ : append sourceBundleHeader 171 (append (sourceBundleSection 1 96 manifestSize) 172 (append (sourceBundleSection 2 (add manifestSize 96) 173 nodesSize) 174 (append manifest nodes)))) 175 (sourceBundleCount nodes)) 176 (sourceBundleCount manifest) 177 sourceBundleEncode namedTrees = 178 lazyList 179 (_ : err "bundle requires an export" t) 180 (_ _ : matchPair (roots nodes : 181 ok (sourceBundleAssemble (sourceBundleManifest roots) 182 (sourceBundleNodes nodes)) t) 183 (sourceBundleIndex namedTrees)) 184 namedTrees 185 186 sourceBundleHydrate entries root namedTrees = 187 lazyList 188 (_ : pure (ok (reverse namedTrees) t)) 189 (entry rest : onResult_ (sourceObjectGetTree root (snd entry)) 190 (problem : pure (err problem t)) 191 (tree : sourceBundleHydrate rest root (pair (pair (fst entry) tree) namedTrees))) 192 entries 193 sourceBundlePack root manifestHash outputPath = 194 onResult_ (sourceModuleGetManifest root manifestHash) 195 (problem : pure (err problem t)) 196 (entries : onResult_ (sourceBundleHydrate entries root t) 197 (problem : pure (err problem t)) 198 (named : lazyResult 199 (problem unused : pure (err problem t)) 200 (bytes unused : onOk_ (sha256Hex bytes) (bundleHash : 201 onOk_ (atomicWriteBytes outputPath bytes) (_ : 202 pure (ok bundleHash t)))) 203 (sourceBundleEncode named))) 204