tricu

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

09645b5e34d4cb719940ffeb8625e015f8bbaf7c8f73bc9fa73ac2b01493d016.tri (8021B)

      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 sourceBundleSplitByte_ self 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         (_ : self rest (pred places) (add weight weight)
     20           (add byte (matchBool weight 0 bit)))
     21         (equal? places 1))
     22     number
     23 sourceBundleSplitByte number = y sourceBundleSplitByte_ 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_ self tree state =
     67   triage
     68     (sourceBundleAdd t state)
     69     (child : matchPair (index next : sourceBundleAdd (t index) next)
     70       (self child state))
     71     (left right : matchPair (leftIndex next :
     72       matchPair (rightIndex after :
     73         sourceBundleAdd (t leftIndex rightIndex) after)
     74         (self right next))
     75       (self left state))
     76     tree
     77 sourceBundleVisit tree state = y sourceBundleVisit_ tree state
     78 sourceBundleIndex_ self exports state roots =
     79   lazyList
     80     (_ : pair (reverse roots) (reverse (fst (snd state))))
     81     (entry rest : matchPair (index after :
     82       self rest after (pair (pair (fst entry) index) roots))
     83       (sourceBundleVisit (snd entry) state))
     84     exports
     85 sourceBundleIndex namedTrees =
     86   y sourceBundleIndex_ namedTrees (pair 0 (pair t t)) t
     87 
     88 sourceBundlePayload key =
     89   triage
     90     [(0)]
     91     (child : pair 1 (sourceBundleU32 child))
     92     (left right : pair 2 (append (sourceBundleU32 left)
     93       (sourceBundleU32 right)))
     94     key
     95 sourceBundleNodeEntry key =
     96   triage
     97     (append (sourceBundleU32 1) (sourceBundlePayload key))
     98     (_ : append (sourceBundleU32 5) (sourceBundlePayload key))
     99     (_ _ : append (sourceBundleU32 9) (sourceBundlePayload key))
    100     key
    101 sourceBundleNodeEntries_ self nodes =
    102   lazyList
    103     (_ : t)
    104     (key rest : append (sourceBundleNodeEntry key) (self rest))
    105     nodes
    106 sourceBundleNodes nodes =
    107   append (sourceBundleU64 (length nodes)) (y sourceBundleNodeEntries_ nodes)
    108 
    109 sourceBundleRootEntry root first =
    110   append (sourceBundleU32 (snd root))
    111     (sourceBundleText (matchBool "default" "root" first))
    112 sourceBundleRootEntries_ self roots first =
    113   lazyList
    114     (_ : t)
    115     (root rest : append (sourceBundleRootEntry root first)
    116       (self rest false))
    117     roots
    118 sourceBundleExportEntry root =
    119   append (sourceBundleText (fst root))
    120     (append (sourceBundleU32 (snd root))
    121       (append (sourceBundleText "term")
    122         (sourceBundleText "arboricx.abi.tree.v1")))
    123 sourceBundleExportEntries_ self roots =
    124   lazyList
    125     (_ : t)
    126     (root rest : append (sourceBundleExportEntry root) (self rest))
    127     roots
    128 sourceBundleManifest roots =
    129   append "ARBMNFST" (append [(0) (1) (0) (1)]
    130     (append (sourceBundleText "arboricx.bundle.manifest.v1")
    131       (append (sourceBundleText "tree-calculus-executable-object")
    132         (append (sourceBundleText "tree-calculus.v1")
    133           (append (sourceBundleText "indexed")
    134             (append (sourceBundleText "arboricx.indexed.node.v1")
    135               (append (sourceBundleText "arboricx.indexed.payload.v1")
    136                 (append (sourceBundleText "tree-calculus.v1")
    137                   (append (sourceBundleText "normal-order")
    138                     (append (sourceBundleText "arboricx.abi.tree.v1")
    139                       (append (sourceBundleU32 0)
    140                         (append [(0)]
    141                           (append (sourceBundleU32 (length roots))
    142                             (append (y sourceBundleRootEntries_ roots true)
    143                               (append (sourceBundleU32 (length roots))
    144                                 (append (y sourceBundleExportEntries_ roots)
    145                                   (append (sourceBundleU32 1)
    146                                     (append [(0) (5) (0) (0) (0) (8)]
    147                                       (append "arboricx" (sourceBundleU32 0))))))))))))))))))))
    148 sourceBundleSection section offset size =
    149   append (sourceBundleU32 section)
    150     (append [(0) (1) (0) (1) (0) (0) (0) (0)]
    151       (append (sourceBundleU64 offset)
    152         (append (sourceBundleU64 size) (sourceBundleU32 0))))
    153 sourceBundleHeader =
    154   append "ARBORICX" (append [(0) (1) (0) (0)]
    155     (append (sourceBundleU32 2)
    156       (append (sourceBundleU64 0) (sourceBundleU64 32))))
    157 -- Complete the variable-length sections before exposing their lengths to
    158 -- fixed-width integer encoders; forcing an abstract `length` as bits can
    159 -- otherwise drive unbounded normalization of an unknown stream.
    160 sourceBundleCount_ self bytes count =
    161   lazyList
    162     (_ : ok count t)
    163     (_ rest : self rest (succ count))
    164     bytes
    165 sourceBundleCount bytes = y sourceBundleCount_ bytes 0
    166 sourceBundleAssemble manifest nodes =
    167   lazyResult
    168     (_ _ : t)
    169     (manifestSize _ : lazyResult
    170       (_ _ : t)
    171       (nodesSize _ : append sourceBundleHeader
    172         (append (sourceBundleSection 1 96 manifestSize)
    173           (append (sourceBundleSection 2 (add manifestSize 96)
    174             nodesSize)
    175             (append manifest nodes))))
    176       (sourceBundleCount nodes))
    177     (sourceBundleCount manifest)
    178 sourceBundleEncode namedTrees =
    179   lazyList
    180     (_ : err "bundle requires an export" t)
    181     (_ _ : matchPair (roots nodes :
    182       ok (sourceBundleAssemble (sourceBundleManifest roots)
    183         (sourceBundleNodes nodes)) t)
    184       (sourceBundleIndex namedTrees))
    185     namedTrees
    186 
    187 sourceBundleHydrate_ self entries root namedTrees =
    188   lazyList
    189     (_ : pure (ok (reverse namedTrees) t))
    190     (entry rest : onResult_ (sourceObjectGetTree root (snd entry))
    191       (problem : pure (err problem t))
    192       (tree : self rest root (pair (pair (fst entry) tree) namedTrees)))
    193     entries
    194 sourceBundlePack root manifestHash outputPath =
    195   onResult_ (sourceModuleGetManifest root manifestHash)
    196     (problem : pure (err problem t))
    197     (entries : onResult_ (y sourceBundleHydrate_ entries root t)
    198       (problem : pure (err problem t))
    199       (named : lazyResult
    200         (problem unused : pure (err problem t))
    201         (bytes unused : onOk_ (sha256Hex bytes) (bundleHash :
    202           onOk_ (atomicWriteBytes outputPath bytes) (_ :
    203             pure (ok bundleHash t))))
    204         (sourceBundleEncode named)))
    205