tricu

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

4aa8022ee52d1cb6df0f45e794328109f74b1dd32b2fae1d5a3c9fec172bfd82.tri (5076B)

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