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