tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

bea75689ba66f19e241f97369ea7ee1393fabbaa7c7eac9b9a2d0ca1e455a1bf.tri (8941B)

      1 !import base as B
      2 !import native_math as N
      3 !export *
      4 
      5 -- Experimental native structured IO with named, versioned facilities.
      6 -- No runtime read/write grants: native execution uses OS process authority.
      7 io action = B.pair "tricuIO" (B.pair 2 action)
      8 pure value = B.pair 0 value
      9 bind action next = B.pair 1 (B.pair action next)
     10 fail diagnostic = B.pair 2 diagnostic
     11 scope body = B.pair 3 body
     12 currentScope = B.pair 4 t
     13 -- Flags are canonical 0/1, not truthy values. Callback receives fresh handles.
     14 -- Success is [task joinTicket]; non-result children receive t in the ticket slot.
     15 spawn supervised keep handles body = B.pair 5
     16   (B.pair supervised (B.pair keep (B.pair handles body)))
     17 join ticket = B.pair 6 ticket
     18 discard ticket = B.pair 7 ticket
     19 cancel task reason = B.pair 8 (B.pair task reason)
     20 cancelled reason = B.pair 9 reason
     21 -- Named, independently versioned host facilities; core sequencing stays separate.
     22 request group revision operation arguments = B.pair 10
     23   (B.pair group (B.pair revision (B.pair operation arguments)))
     24 capabilities = request "runtime" 1 "capabilities" t
     25 inspect action = request "runtime" 1 "inspect" action
     26 stdin = request "standard" 1 "input" t
     27 stdout = request "standard" 1 "output" t
     28 stderr = request "standard" 1 "error" t
     29 openReader owner path = request "file" 1 "open-reader" (B.pair owner path)
     30 openWriter owner path = request "file" 1 "open-writer" (B.pair owner path)
     31 openAppender owner path = request "file" 1 "open-appender" (B.pair owner path)
     32 openUpdate owner path = request "file" 1 "open-update" (B.pair owner path)
     33 seekFile handle offset = request "file" 1 "seek" (B.pair handle offset)
     34 filePosition handle = request "file" 1 "position" handle
     35 syncFile handle = request "file" 1 "sync" handle
     36 syncDirectory path = request "directory" 1 "sync" path
     37 fileSize handle = request "file" 1 "size" handle
     38 resizeFile handle size = request "file" 1 "resize" (B.pair handle size)
     39 statPath path = request "path" 1 "stat" path
     40 lstatPath path = request "path" 1 "lstat" path
     41 removeFile path = request "path" 1 "remove-file" path
     42 renamePath source destination = request "path" 1 "rename" (B.pair source destination)
     43 createDirectory path = request "directory" 1 "create" path
     44 removeDirectory path = request "directory" 1 "remove" path
     45 openDirectory owner path = request "directory" 1 "open" (B.pair owner path)
     46 nextDirectory directory = request "directory" 1 "next" directory
     47 ipv4 octets port = ["ipv4" octets port]
     48 ipv6 words scope port = ["ipv6" words scope port]
     49 resolveTCP host family port limit = request "resolver" 1 "resolve" [host family port limit]
     50 listenTCP owner address backlog = request "tcp" 1 "listen" (B.pair owner (B.pair address backlog))
     51 connectTCP owner address = request "tcp" 1 "connect" (B.pair owner address)
     52 acceptTCP listener owner = request "tcp" 1 "accept" (B.pair listener owner)
     53 localAddress socket = request "tcp" 1 "local-address" socket
     54 peerAddress socket = request "tcp" 1 "peer-address" socket
     55 shutdownWrite socket = request "tcp" 1 "shutdown-write" socket
     56 -- One authenticated frame from the current cursor; no following-byte EOF probe.
     57 -- Temporary disk <= size; limit is caller policy, not an aggregate scope quota.
     58 readIndexedTree reader directory limit size digest = request "indexed-tree" 1 "read"
     59   [reader directory limit size digest]
     60 -- Canonical native encoding avoids expanded tree/byte lists. The writer checks
     61 -- the size and expected digest before sending; failure is not retry permission.
     62 hashIndexedTree limit tree = request "indexed-tree" 1 "hash" (B.pair limit tree)
     63 writeIndexedTree writer limit digest tree = request "indexed-tree" 1 "write"
     64   [writer limit digest tree]
     65 -- Exact canonical-byte comparison consumes one frame; it does not probe EOF.
     66 verifyIndexedTree reader limit tree = request "indexed-tree" 1 "verify" [reader limit tree]
     67 -- Stateless bounded codecs: decode returns [text carry], with carry <=3 octets.
     68 -- Set final=1 at EOF to reject incomplete suffixes. NUL and BOM are valid scalars;
     69 -- source-file BOM rejection is library/application policy, not UTF-8 decoding.
     70 encodeUTF8 text = request "utf8" 1 "encode" text
     71 decodeUTF8 final bytes = request "utf8" 1 "decode" [final bytes]
     72 readSome reader limit = request "stream" 1 "read" (B.pair reader limit)
     73 writeSome writer bytes = request "stream" 1 "write" (B.pair writer bytes)
     74 close handle = request "resource" 1 "close" handle
     75 openStage owner directory = request "stage" 1 "open" (B.pair owner directory)
     76 sealStage stage = request "stage" 1 "seal" stage
     77 publishNew stage destination = request "stage" 1 "publish" (B.pair stage (B.pair 0 destination))
     78 publishReplace stage destination = request "stage" 1 "publish" (B.pair stage (B.pair 1 destination))
     79 openDigest owner algorithm = request "digest" 1 "open" (B.pair owner algorithm)
     80 updateDigest digest bytes = request "digest" 1 "update" (B.pair digest bytes)
     81 finishDigest digest = request "digest" 1 "finish" digest
     82 
     83 onOk action next = bind action (reply : case reply of
     84   ((t t), (value, t)) = next value
     85   (t, (_, t)) = pure reply
     86   _ = fail "Invalid operation Result")
     87 
     88 -- Nonrecursive initialization for caller-ordered store directory creation.
     89 -- An existing symlink to a directory is accepted through stat, not confinement.
     90 ensureDirectory path = bind (createDirectory path) (reply : case reply of
     91   (t, (["already-exists" _ _ _], t)) = onOk (statPath path) (status : case status of
     92     ["directory"] = pure (B.ok t t)
     93     _ = pure (B.err ["not-directory" "directory/ensure" "" "none"] t))
     94   _ = pure reply)
     95 
     96 -- Explicit sequential fallback policy, separate from native connect/resolve.
     97 -- Stop on the first success; preserve the last ordinary failure unchanged.
     98 connectFirstTCP owner addresses = connectCandidates owner addresses
     99   (B.err ["not-found" "tcp/connect-first" "No endpoint candidates" "none"] t)
    100 connectCandidates _ [] previous = pure previous
    101 connectCandidates owner [address | rest] _ = bind (connectTCP owner address) (reply : case reply of
    102   ((t t), (_, t)) = pure reply
    103   (t, (_, t)) = connectCandidates owner rest reply
    104   _ = fail "Invalid connection Result")
    105 connectCandidates _ _ _ = pure (B.err ["invalid-argument" "tcp/connect-first" "Invalid endpoint list" "none"] t)
    106 
    107 -- Turn an explicitly selected operation failure into terminal task failure.
    108 -- Ordinary Results elsewhere remain values, not implicit exceptions.
    109 require action next = bind action (reply : case reply of
    110   ((t t), (value, t)) = next value
    111   (t, (problem, t)) = fail problem
    112   _ = fail "Invalid operation Result")
    113 
    114 -- Whole-chunk convenience over the native positive-progress contract. Failure
    115 -- stops immediately: unknown progress must never trigger a whole-chunk retry.
    116 dropWritten 0 bytes = bytes
    117 dropWritten count [_ | rest] = dropWritten (N.predecessor count) rest
    118 dropWritten _ _ = []
    119 -- Failure carries confirmed progress BEFORE the failing writeSome, plus its
    120 -- unchanged diagnostic (whose own progress can be unknown). Never report that
    121 -- last operation's "none" as if the whole composite write had no effects.
    122 writeAll writer bytes = let rec
    123   walk accepted remaining = case remaining of
    124     [] = pure (B.ok t t)
    125     _ = bind (writeSome writer remaining) (reply : case reply of
    126       ((t t), (count, t)) = walk (N.add accepted count) (dropWritten count remaining)
    127       (t, (problem, t)) = pure (B.err ["write-all" accepted problem] t)
    128       _ = fail "Invalid operation Result")
    129   in walk 0 bytes
    130 
    131 -- Sequential bounded pumping, without acquiring or closing either endpoint.
    132 -- Errors retain writeAll's confirmed prefix and original uncertain progress.
    133 copyStream reader writer = do onOk
    134   received <- readSome reader 4096
    135   case received of
    136     ("eof", t) = pure (B.ok t t)
    137     ("data", bytes) = do onOk
    138       writeAll writer bytes
    139       copyStream reader writer
    140     _ = fail "Invalid read reply"
    141 
    142 -- Relative waits and native monotonic observations, not wall-clock timestamps or
    143 -- hard deadlines. Yield only offers a scheduling opportunity, not alternation.
    144 monotonicNanoseconds = request "clock" 1 "monotonic" t
    145 sleepMilliseconds milliseconds = request "clock" 1 "sleep" milliseconds
    146 yield = request "scheduler" 1 "yield" t
    147 
    148 -- Returns Result [task joinTicket stdinWriter stdoutReader stderrReader].
    149 -- cwd: ["inherit"] or ["at" path]; env: ["inherit"] or ["replace" [[key value] ...]].
    150 -- Normal scope exit waits. Close stdin for EOF; drain stdout/stderr concurrently.
    151 -- Join completion holds ["exit" code] or ["signal" number], not an IO failure.
    152 spawnProcess executable arguments directory environment graceMilliseconds =
    153   request "process" 1 "spawn" [executable arguments directory environment graceMilliseconds]
    154 
    155 -- Read-only host context, not a language environment/state slot. Environment
    156 -- query returns ["missing"] or ["value" text]; empty and absent remain distinct.
    157 workingDirectory = request "process" 1 "working-directory" t
    158 environmentVariable name = request "process" 1 "environment-variable" name