73cfe94509cdbc3c234bf4dabfac1796f5c6cf92565fcdd5a673a865bb8cd65b.tri (8334B)
1 !import base as B 2 !import io_v2 as V2 3 !export pure 4 !export bind 5 !export request 6 !export checkedRequest 7 !export checkWith 8 !export checkRequest 9 !export handle 10 !export forward 11 !export label 12 !export fail 13 !export liftIO 14 !export runPure 15 !export runIO 16 !export collect 17 !export view 18 !export diagnostic 19 !export scopeV2 20 !export spawnV2 21 !export runIOV2 22 23 -- Request/response effects. Handler callbacks return computations yielding one 24 -- reply. liftIO bridges host actions into this protocol. 25 pure value = B.pair 100 value 26 bind action next = B.pair 101 (B.pair action next) 27 request service operation argument = B.pair 102 (B.pair [service operation argument] pure) 28 handle service handler action = B.pair 104 (B.pair [service handler] action) 29 label name action = B.pair 105 (B.pair [name] action) 30 fail kind service operation detail = B.pair 103 [kind service operation detail] 31 32 -- Handlers execute outside their own installation scope, so forwarding is an 33 -- ordinary request there. At other call sites it uses the current environment. 34 -- Service names select routes; host operations use OS process authority. 35 forward = request 36 liftIO action = request "host.io" "run" action 37 38 -- Boundary constructors snapshot the actual lexical environment during 39 -- normalization, including when invoked inside a handler callback. 40 -- Child frames start empty; immutable routing and label values are inherited. 41 scopeV2 body = B.pair 107 body 42 spawnV2 supervised keep handles body = B.pair 108 [supervised keep handles body] 43 44 -- Diagnostics are data: kind, service, operation, detail, outer-to-inner labels. 45 diagnostic kind service operation detail labels = [kind service operation detail labels] 46 47 -- Check once, then select one continuation. Success passes the checked value; 48 -- rejection passes its diagnostic; a malformed reply passes the original value. 49 -- Each continuation owns its outcome policy and only the selected one runs. 50 checkWith contract value rejected malformed next = case B.checkContract contract value of 51 ((t t), (checked, t)) = next checked 52 (t, (message, _)) = rejected message 53 _ = malformed value 54 55 -- Request-boundary policy carries routing details into handler diagnostics. 56 checkRequest service operation contract argument = checkWith contract argument 57 (message : fail "invalid-request" service operation message) 58 (original : fail "invalid-request-contract" service operation original) 59 60 checkedRequest service operation inputC outputC argument = 61 checkRequest service operation inputC argument (checked : do bind 62 reply <- request service operation checked 63 checkWith outputC reply 64 (message : fail "invalid-response" service operation message) 65 (original : fail "invalid-response-contract" service operation original) 66 pure) 67 68 findHandler wanted [[service handler] | outer] = B.lazyBool 69 (_ : B.pair handler outer) 70 (_ : findHandler wanted outer) 71 (B.equal? wanted service) 72 findHandler _ _ = t 73 74 -- Normalized views: 100 value; 103 complete diagnostic; 106 ([service op arg], 75 -- outer-to-inner labels, reply continuation). View stops at the first request. 76 -- Frames retain caller environments and labels; handlers use the environment 77 -- suffix outside their installation, but keep the requesting execution's labels. 78 normalize action environment frames labels = let 79 broken = B.pair 103 (diagnostic "invalid-computation" t t t labels) 80 resume value [] = pure value 81 -- Force the popped stack tail's outer constructor before reusing it. A lazy 82 -- projection here can keep consumed frames (and their old chunks) reachable. 83 resume value [[saved savedLabels next] | rest] = case rest of 84 [] = normalize (next value) saved [] savedLabels 85 more{[_ | _]} = normalize (next value) saved more savedLabels 86 _ = broken 87 resume _ _ = broken 88 dispatch event{[service operation argument]} next = case findHandler service environment of 89 (handler, outer) = normalize (handler operation argument) outer 90 (B.pair [environment labels next] frames) labels 91 _ = B.pair 106 [event labels (reply : normalize (next reply) environment frames labels)] 92 dispatch _ _ = broken 93 in case action of 94 (100, value) = resume value frames 95 (101, (first, next)) = normalize first environment (B.pair [environment labels next] frames) labels 96 (102, (event, next)) = dispatch event next 97 (103, [kind service operation detail]) = B.pair 103 (diagnostic kind service operation detail labels) 98 (104, (entry{[service handler]}, body)) = normalize body (B.pair entry environment) 99 (B.pair [environment labels pure] frames) labels 100 (105, (extraLabels, body)) = normalize body environment 101 (B.pair [environment labels pure] frames) (B.append labels extraLabels) 102 (107, body) = B.pair 107 [labels 103 (owner : normalize (body owner) environment [] labels) 104 (reply : resume reply frames)] 105 (108, [supervised keep handles body]) = B.pair 108 [supervised keep handles labels 106 (fresh : normalize (body fresh) environment [] labels) 107 (reply : resume reply frames)] 108 _ = broken 109 110 view action = normalize action [] [] [] 111 112 -- Execution Result is distinct from an operation's ordinary Result value. 113 -- Pure interpretation rejects every unhandled request, including host IO. 114 runPure action = case view action of 115 (100, value) = B.ok value t 116 (103, problem) = B.err problem t 117 (106, [[service operation argument] labels next]) = B.err 118 (diagnostic "unhandled-request" service operation argument labels) t 119 _ = B.err (diagnostic "invalid-view" t t t []) t 120 121 -- Handler failures become terminal v2 outcomes. Ordinary service Results remain 122 -- values. Labels/continuations stay lazy; only the label list spine is checked. 123 runHostV2 current = case current of 124 (100, value) = V2.pure value 125 (103, problem) = V2.fail problem 126 (106, [["host.io" "run" action] labels next]) = case B.checkContract (B.listOf B.anyC) labels of 127 ((t t), _) = V2.bind action (reply : runHostV2 (next reply)) 128 _ = V2.fail (diagnostic "invalid-view" t t t []) 129 (106, [[service operation argument] labels next]) = V2.fail 130 (diagnostic "unhandled-request" service operation argument labels) 131 (107, [labels body next]) = case B.checkContract (B.listOf B.anyC) labels of 132 ((t t), _) = V2.bind (V2.scope (owner : runHostV2 (body owner))) 133 (reply : runHostV2 (next reply)) 134 _ = V2.fail (diagnostic "invalid-view" t t t []) 135 (108, [supervised keep handles labels body next]) = case B.checkContract (B.listOf B.anyC) labels of 136 ((t t), _) = V2.bind (V2.spawn supervised keep handles (fresh : runHostV2 (body fresh))) 137 (reply : runHostV2 (next reply)) 138 _ = V2.fail (diagnostic "invalid-view" t t t []) 139 _ = V2.fail (diagnostic "invalid-view" t t t []) 140 runIOV2 action = runHostV2 (view action) 141 runIO = runIOV2 142 143 -- Collection threads its accumulator through a boundary transformer. 144 -- Inner handlers run first. Other residual requests are relayed to outer 145 -- handlers, with their labels scoped ONLY around the forwarded request. 146 -- It returns [value chronological-events]. Failures retain their labels. 147 collect service operation argumentC reply action = let rec 148 walk current reversed = case current of 149 (100, value) = pure [value (B.reverse reversed)] 150 (103, [kind failedService failedOperation detail labels]) = B.pair 105 151 (B.pair labels (fail kind failedService failedOperation detail)) 152 (106, [event{[wanted op argument]} labels next]) = B.lazyBool 153 (_ : case B.checkContract argumentC argument of 154 ((t t), (checked, t)) = walk (next reply) (B.pair checked reversed) 155 (t, (message, _)) = B.pair 105 (B.pair labels (fail "invalid-request" service operation message)) 156 _ = B.pair 105 (B.pair labels (fail "invalid-request-contract" service operation argument))) 157 (_ : bind (B.pair 105 (B.pair labels (request wanted op argument))) 158 (answer : walk (next answer) reversed)) 159 (B.and? (B.equal? wanted service) (B.equal? op operation)) 160 (107, [labels body next]) = B.pair 105 (B.pair labels 161 (fail "state-boundary" service operation "Install collection inside the scoped body")) 162 (108, [supervised keep handles labels body next]) = B.pair 105 (B.pair labels 163 (fail "state-boundary" service operation "Install child-local collection explicitly")) 164 _ = fail "invalid-view" t t t 165 in walk (view action) []