tricu/lib/arboricx.tri

!import "arboricx-manifest.tri" !Local

-- Read and validate a full Arboricx bundle.
-- Returns (pair validManifest afterContainer).
-- The manifest core fields are validated against expected values.
readArboricxBundle = (bs :
  bindResult (readArboricxRequiredSections bs)
    (sections afterContainer :
      matchPair
        (manifestBytes _ :
          bindResult (readManifest manifestBytes)
            (parsedManifest afterManifest :
              matchPair
                (coreManifest metadataWithExtensions :
                  bindResult (validateManifestCore coreManifest afterManifest)
                    (validCore _ : ok (pair validCore metadataWithExtensions) afterContainer))
                parsedManifest))
        sections))

-- Select an export from a validated bundle and reconstruct its root tree.
-- Returns ok executable afterContainer, or propagates parse/selection/node errors.
readArboricxExecutableByName = (nameBytes bs :
  bindResult (readArboricxBundle bs)
    (bundleResult afterBundle :
      matchPair
        (validCore _ :
          bindResult (selectExport (manifestExports validCore) nameBytes)
            (selectedExport _ :
              readArboricxTreeFromIndex (exportRoot selectedExport) bs))
        bundleResult))

readArboricxExecutable = (bs :
  readArboricxExecutableByName [] bs)

applyArgs = (f args :
  foldl
    (acc arg : acc arg)
    f
    args)

runArboricxByName = (nameBytes bs arg :
  bindResult (readArboricxExecutableByName nameBytes bs)
    (executable rest : ok (executable arg) rest))

runArboricx = (bs arg :
  runArboricxByName [] bs arg)

runArboricxArgsByName = (nameBytes bs args :
  bindResult (readArboricxExecutableByName nameBytes bs)
    (executable rest : ok (applyArgs executable args) rest))

runArboricxArgs = (bs args :
  runArboricxArgsByName [] bs args)

errHostCodecFailed = 14

hostTreeTag = 0
hostStringTag = 1
hostNumberTag = 2
hostBoolTag = 3
hostListTag = 4
hostBytesTag = 5

hostTree = (value : pair hostTreeTag value)
hostString = (bytes : pair hostStringTag bytes)
hostNumber = (n : pair hostNumberTag n)
hostBool = (b : pair hostBoolTag b)
hostList = (xs : pair hostListTag xs)
hostBytes = (bytes : pair hostBytesTag bytes)

hostValueTag = (hostValue : pairFirst hostValue)
hostValuePayload = (hostValue : pairSecond hostValue)

hostBool? = (value : or? (equal? value false) (equal? value true))

hostNumber? = y (self value :
  triage
    true
    (_ : false)
    (bit rest :
      and?
        (or? (equal? bit false) (equal? bit true))
        (self rest))
    value)

hostList? = y (self value :
  triage
    true
    (_ : false)
    (_ rest : self rest)
    value)

hostString? = y (self value :
  matchList
    true
    (byte rest : and? (hostNumber? byte) (self rest))
    value)

hostBytes? = hostString?

wrapHostValue = (validator wrapper resultValue rest :
  matchBool
    (ok (wrapper resultValue) rest)
    (err errHostCodecFailed resultValue)
    (validator resultValue))

wrapHostValueByTag = (tag value rest :
  matchBool
    (ok (hostTree value) rest)
    (matchBool
      (wrapHostValue hostString? hostString value rest)
      (matchBool
        (wrapHostValue hostNumber? hostNumber value rest)
        (matchBool
          (wrapHostValue hostBool? hostBool value rest)
          (matchBool
            (wrapHostValue hostList? hostList value rest)
            (matchBool
              (wrapHostValue hostBytes? hostBytes value rest)
              (err errHostCodecFailed value)
              (equal? tag hostBytesTag))
            (equal? tag hostListTag))
          (equal? tag hostBoolTag))
        (equal? tag hostNumberTag))
      (equal? tag hostStringTag))
    (equal? tag hostTreeTag))

runArboricxByNameToTyped = (tag nameBytes bs args :
  bindResult (runArboricxArgsByName nameBytes bs args)
    (value rest : wrapHostValueByTag tag value rest))

runArboricxByNameToTree = (nameBytes bs args :
  runArboricxByNameToTyped hostTreeTag nameBytes bs args)

runArboricxByNameToString = (nameBytes bs args :
  runArboricxByNameToTyped hostStringTag nameBytes bs args)

runArboricxByNameToNumber = (nameBytes bs args :
  runArboricxByNameToTyped hostNumberTag nameBytes bs args)

runArboricxByNameToBool = (nameBytes bs args :
  runArboricxByNameToTyped hostBoolTag nameBytes bs args)

runArboricxByNameToList = (nameBytes bs args :
  runArboricxByNameToTyped hostListTag nameBytes bs args)

runArboricxByNameToBytes = (nameBytes bs args :
  runArboricxByNameToTyped hostBytesTag nameBytes bs args)

runArboricxToTree = (bs args : runArboricxByNameToTyped hostTreeTag [] bs args)
runArboricxToString = (bs args : runArboricxByNameToTyped hostStringTag [] bs args)
runArboricxToNumber = (bs args : runArboricxByNameToTyped hostNumberTag [] bs args)
runArboricxToBool = (bs args : runArboricxByNameToTyped hostBoolTag [] bs args)
runArboricxToList = (bs args : runArboricxByNameToTyped hostListTag [] bs args)
runArboricxToBytes = (bs args : runArboricxByNameToTyped hostBytesTag [] bs args)