tricu

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

arboricx.tri (5109B)

      1 !import "prelude"           !Local
      2 !import "arboricx.common"   !Local
      3 !import "arboricx.manifest" !Local
      4 !import "arboricx.nodes"    !Local
      5 
      6 -- Read and validate a full Arboricx bundle.
      7 -- Returns (pair validManifest afterContainer).
      8 -- The manifest core fields are validated against expected values.
      9 readArboricxBundle = (bs :
     10   bindResult (readArboricxRequiredSections bs)
     11     (sections afterContainer :
     12       matchPair
     13         (manifestBytes _ :
     14           bindResult (readManifest manifestBytes)
     15             (parsedManifest afterManifest :
     16               matchPair
     17                 (coreManifest metadataWithExtensions :
     18                   bindResult (validateManifestCore coreManifest afterManifest)
     19                     (validCore _ : ok (pair validCore metadataWithExtensions) afterContainer))
     20                 parsedManifest))
     21         sections))
     22 
     23 -- Select an export from a validated bundle and reconstruct its root tree.
     24 -- Returns ok executable afterContainer, or propagates parse/selection/node errors.
     25 readArboricxExecutableByName = (nameBytes bs :
     26   bindResult (readArboricxBundle bs)
     27     (bundleResult afterBundle :
     28       matchPair
     29         (validCore _ :
     30           bindResult (selectExport (manifestExports validCore) nameBytes)
     31             (selectedExport _ :
     32               readArboricxTreeFromIndex (exportRoot selectedExport) bs))
     33         bundleResult))
     34 
     35 readArboricxExecutable = (bs :
     36   readArboricxExecutableByName [] bs)
     37 
     38 applyArgs = (f args :
     39   foldl
     40     (acc arg : acc arg)
     41     f
     42     args)
     43 
     44 runArboricxByName = (nameBytes bs arg :
     45   bindResult (readArboricxExecutableByName nameBytes bs)
     46     (executable rest : ok (executable arg) rest))
     47 
     48 runArboricx = (bs arg :
     49   runArboricxByName [] bs arg)
     50 
     51 runArboricxArgsByName = (nameBytes bs args :
     52   bindResult (readArboricxExecutableByName nameBytes bs)
     53     (executable rest : ok (applyArgs executable args) rest))
     54 
     55 runArboricxArgs = (bs args :
     56   runArboricxArgsByName [] bs args)
     57 
     58 errHostCodecFailed = 14
     59 
     60 hostTreeTag = 0
     61 hostStringTag = 1
     62 hostNumberTag = 2
     63 hostBoolTag = 3
     64 hostListTag = 4
     65 hostBytesTag = 5
     66 
     67 hostTree = (value : pair hostTreeTag value)
     68 hostString = (bytes : pair hostStringTag bytes)
     69 hostNumber = (n : pair hostNumberTag n)
     70 hostBool = (b : pair hostBoolTag b)
     71 hostList = (xs : pair hostListTag xs)
     72 hostBytes = (bytes : pair hostBytesTag bytes)
     73 
     74 hostValueTag = (hostValue : pairFirst hostValue)
     75 hostValuePayload = (hostValue : pairSecond hostValue)
     76 
     77 hostBool? = (value : or? (equal? value false) (equal? value true))
     78 
     79 hostNumber? = y (self value :
     80   triage
     81     true
     82     (_ : false)
     83     (bit rest :
     84       and?
     85         (or? (equal? bit false) (equal? bit true))
     86         (self rest))
     87     value)
     88 
     89 hostList? = y (self value :
     90   triage
     91     true
     92     (_ : false)
     93     (_ rest : self rest)
     94     value)
     95 
     96 hostString? = y (self value :
     97   matchList
     98     true
     99     (byte rest : and? (hostNumber? byte) (self rest))
    100     value)
    101 
    102 hostBytes? = hostString?
    103 
    104 wrapHostValue = (validator wrapper resultValue rest :
    105   matchBool
    106     (ok (wrapper resultValue) rest)
    107     (err errHostCodecFailed resultValue)
    108     (validator resultValue))
    109 
    110 wrapHostValueByTag = (tag value rest :
    111   matchBool
    112     (ok (hostTree value) rest)
    113     (matchBool
    114       (wrapHostValue hostString? hostString value rest)
    115       (matchBool
    116         (wrapHostValue hostNumber? hostNumber value rest)
    117         (matchBool
    118           (wrapHostValue hostBool? hostBool value rest)
    119           (matchBool
    120             (wrapHostValue hostList? hostList value rest)
    121             (matchBool
    122               (wrapHostValue hostBytes? hostBytes value rest)
    123               (err errHostCodecFailed value)
    124               (equal? tag hostBytesTag))
    125             (equal? tag hostListTag))
    126           (equal? tag hostBoolTag))
    127         (equal? tag hostNumberTag))
    128       (equal? tag hostStringTag))
    129     (equal? tag hostTreeTag))
    130 
    131 runArboricxByNameToTyped = (tag nameBytes bs args :
    132   bindResult (runArboricxArgsByName nameBytes bs args)
    133     (value rest : wrapHostValueByTag tag value rest))
    134 
    135 runArboricxByNameToTree = (nameBytes bs args :
    136   runArboricxByNameToTyped hostTreeTag nameBytes bs args)
    137 
    138 runArboricxByNameToString = (nameBytes bs args :
    139   runArboricxByNameToTyped hostStringTag nameBytes bs args)
    140 
    141 runArboricxByNameToNumber = (nameBytes bs args :
    142   runArboricxByNameToTyped hostNumberTag nameBytes bs args)
    143 
    144 runArboricxByNameToBool = (nameBytes bs args :
    145   runArboricxByNameToTyped hostBoolTag nameBytes bs args)
    146 
    147 runArboricxByNameToList = (nameBytes bs args :
    148   runArboricxByNameToTyped hostListTag nameBytes bs args)
    149 
    150 runArboricxByNameToBytes = (nameBytes bs args :
    151   runArboricxByNameToTyped hostBytesTag nameBytes bs args)
    152 
    153 runArboricxToTree = (bs args : runArboricxByNameToTyped hostTreeTag [] bs args)
    154 runArboricxToString = (bs args : runArboricxByNameToTyped hostStringTag [] bs args)
    155 runArboricxToNumber = (bs args : runArboricxByNameToTyped hostNumberTag [] bs args)
    156 runArboricxToBool = (bs args : runArboricxByNameToTyped hostBoolTag [] bs args)
    157 runArboricxToList = (bs args : runArboricxByNameToTyped hostListTag [] bs args)
    158 runArboricxToBytes = (bs args : runArboricxByNameToTyped hostBytesTag [] bs args)