workflow.tri (20138B)
1 !import base * 2 !import io as IO 3 !export * 4 5 -- Experimental protocol, deliberately NOT host IO or base.exceptE. 6 -- 100 return; 101 sequence; 102 request [instance operation argument] + reply k; 7 -- 103 terminal diagnostic. Replies use base Result, with empty remainder. 8 ret value = pair 100 value 9 seq action k = pair 101 (pair action k) 10 request instance operation argument = pair 102 (pair [instance operation argument] ret) 11 stop diagnostic = pair 103 diagnostic 12 13 -- Validate response domains at the shared operation boundary. Preserve failures. 14 checked instance operation action = (seq action (reply : case reply of 15 ((t t), (value, t)) = checkValue instance operation value 16 (t, (message, t)) = stop message 17 _ = stop [90 instance operation])) 18 checkValue instance 1 0 = ret 0 19 checkValue instance 1 1 = ret 1 20 checkValue instance 2 1 = ret 1 21 checkValue instance 3 42 = ret 42 22 checkValue instance 4 1 = ret 1 23 checkValue instance 5 7 = ret 7 24 checkValue instance operation _ = stop [90 instance operation] 25 -- Clock/read domains are intentionally finite scripted domains, not public codecs. 26 27 -- A: constructed services capture implementation identity. Application-facing 28 -- publishA is itself a closure after supplying its small three-service bundle. 29 service instance operation argument = checked instance operation (request instance operation argument) 30 services store = [ (service store) (service 20) (service 30) ] 31 storeOf [store clock logger] = store 32 storeOf _ = (operation argument : stop [91 1 operation]) 33 clockOf [store clock logger] = clock 34 clockOf _ = (operation argument : stop [91 2 operation]) 35 logOf [store clock logger] = logger 36 logOf _ = (operation argument : stop [91 3 operation]) 37 38 publishA dependencies artifact = (do seq 39 exists <- storeOf dependencies 1 artifact 40 publishAbsentA dependencies artifact exists) 41 publishAbsentA dependencies artifact 0 = (do seq 42 storeOf dependencies 2 artifact 43 stamp <- clockOf dependencies 3 0 44 logOf dependencies 4 [artifact stamp] 45 ret 1) 46 publishAbsentA _ _ _ = ret 0 47 48 -- Logging added INSIDE a store helper: only service construction changes. 49 loggedStore logger store operation argument = (do seq 50 logger 4 [operation argument] 51 store operation argument) 52 loggedServices store = [(loggedStore (service 30) (service store)) (service 20) (service 30)] 53 54 copyA source destination artifact = (do seq 55 value <- source 5 artifact 56 destination 2 value 57 ret 1) 58 twiceA publisher = (do seq 59 publisher 7 60 publisher 8) 61 62 -- B: application functions emit logical requests. Handlers lower logical 63 -- instance IDs to physical ones. Handler-produced backend requests are outside 64 -- that handler; continuations resume inside it. Unknown requests are forwarded 65 -- WITH the handler reinstalled around their continuations. 66 operation instance op argument = checked instance op (request instance op argument) 67 publishB artifact = (do seq 68 exists <- operation 1 1 artifact 69 publishAbsentB artifact exists) 70 publishAbsentB artifact 0 = (do seq 71 operation 1 2 artifact 72 stamp <- operation 2 3 0 73 operation 3 4 [artifact stamp] 74 ret 1) 75 publishAbsentB _ _ = ret 0 76 77 route wanted backend action = case action of 78 (100, value) = ret value 79 (101, (first, k)) = seq (route wanted backend first) (value : route wanted backend (k value)) 80 (102, ([instance op argument], k)) = (lazyBool 81 (_ : seq (request backend op argument) (reply : route wanted backend (k reply))) 82 (_ : pair 102 (pair [instance op argument] (reply : route wanted backend (k reply)))) 83 (equal? wanted instance)) 84 _ = action 85 86 handlers store action = route 3 30 (route 2 20 (route 1 store action)) 87 -- Instrumentation is a handler, not a change to publishB or its callers. 88 logStore action = case action of 89 (100, value) = ret value 90 (101, (first, k)) = seq (logStore first) (value : logStore (k value)) 91 (102, ([1 op argument], k)) = (do seq 92 operation 3 4 [op argument] 93 reply <- request 1 op argument 94 logStore (k reply)) 95 (102, (event, k)) = pair 102 (pair event (reply : logStore (k reply))) 96 _ = action 97 98 copyB artifact = (do seq 99 value <- operation 4 5 artifact 100 operation 5 2 value 101 ret 1) 102 twiceB publisher = (do seq 103 publisher 7 104 publisher 8) 105 106 -- Return [Result, remaining script, chronological trace]. Script rows are 107 -- [expected request, reply]. Neither implementation supplies its own oracle. 108 -- Stack-based evaluator avoids repeatedly rewriting the whole action for bind. 109 run action script = execute action [] script [] 110 execute action stack script reversed = (let 111 resume value [] script reversed = [(ok value t) script (reverse reversed)] 112 resume value [k | stack] script reversed = execute (k value) stack script reversed 113 resume _ _ script reversed = [(err [94] t) script (reverse reversed)] 114 consume event k stack [[expected reply] | script] reversed = (lazyBool 115 (_ : execute (k reply) stack script (pair event reversed)) 116 (_ : [(err [92 event expected] t) (pair [expected reply] script) (reverse (pair event reversed))]) 117 (equal? event expected)) 118 consume event _ _ script reversed = [(err [93 event] t) script (reverse (pair event reversed))] 119 dispatch event{[11 op arg]} k = consume event k stack script reversed 120 dispatch event{[12 op arg]} k = consume event k stack script reversed 121 dispatch event{[20 op arg]} k = consume event k stack script reversed 122 dispatch event{[30 op arg]} k = consume event k stack script reversed 123 dispatch event _ = [(err [95 event] t) script (reverse reversed)] 124 in case action of 125 (100, value) = resume value stack script reversed 126 (101, (first, k)) = execute first (pair k stack) script reversed 127 (102, (event, k)) = dispatch event k 128 (103, diagnostic) = [ (err diagnostic t) script (reverse reversed) ] 129 _ = [ (err [94] t) script (reverse reversed) ]) 130 131 -- Workloads take independently supplied scripts from the Python harness. 132 aPublish script = run (publishA (services 11) 7) script 133 bPublish script = run (handlers 11 (publishB 7)) script 134 aLogged script = run (publishA (loggedServices 11) 7) script 135 bLogged script = run (handlers 11 (logStore (publishB 7))) script 136 aCopy script = run (copyA (service 11) (service 12) 7) script 137 bCopy script = run (route 5 12 (route 4 11 (copyB 7))) script 138 aTwice script = run (twiceA (publishA (services 11))) script 139 bTwice script = run (handlers 11 (twiceB publishB)) script 140 -- Contextual callback: A explicitly constructs/rebinds it for the override; 141 -- B interprets an ordinary callback under the inner handler. 142 withServices dependencies callback = callback dependencies 7 143 withStore backend callback = route 1 backend (callback 7) 144 aOverride script = run (withServices (services 12) publishA) script 145 bOverride script = run (handlers 11 (withStore 12 publishB)) script 146 -- Stable callback: A captures its services; B captures its interpretation. 147 aPinned script = (let 148 publisher = publishA (services 11) 149 in run (withServices (services 12) (_ artifact : publisher artifact)) script) 150 bPinned script = (let 151 publisher artifact = route 1 11 (publishB artifact) 152 in run (handlers 11 (withStore 12 publisher)) script) 153 -- Missing dependency: valid A shape with an explicit missing-service proxy; 154 -- B omits the store handler, leaving the logical request unhandled. 155 aMalformedBundle script = run (publishA [] 7) script 156 aMissing script = run (publishA [(op arg : stop [91 1 op]) (service 20) (service 30)] 7) script 157 bMissing script = run (route 3 30 (route 2 20 (publishB 7))) script 158 159 -- Repeated clock requests; depth is represented as a list of irrelevant IDs. 160 repeatA clock [] = ret 0 161 repeatA clock [_ | rest] = seq (clock 3 0) (_ : repeatA clock rest) 162 repeatA _ _ = stop [94] 163 repeatB [] = ret 0 164 repeatB [_ | rest] = seq (operation 2 3 0) (_ : repeatB rest) 165 repeatB _ = stop [94] 166 wrap [] action = action 167 wrap [id | rest] action = route id 99 (wrap rest action) 168 wrap _ action = action 169 aBench iterations depth script = run (repeatA (service 20) iterations) script 170 bBench iterations depth script = run (route 2 20 (wrap depth (repeatB iterations))) script 171 172 -- Same thin physical adapter for both designs. Real filesystem, fixed clock, 173 -- one artifact domain. No atomic-publication/race-safety claim: this experiment 174 -- tests dependency composition, not the production content-addressed store. 175 -- Ordinary Results only; terminal diagnostics do not become host exceptions. 176 writeBytes path bytes = IO.scope (owner : do IO.onOk 177 writer <- IO.openWriter owner path 178 IO.writeAll writer bytes) 179 physical path logPath [11 1 7] = IO.bind (IO.statPath path) (reply : case reply of 180 ((t t), _) = IO.pure (ok 1 t) 181 (t, (["not-found" operation detail progress], t)) = IO.pure (ok 0 t) 182 _ = IO.pure reply) 183 physical path logPath [11 2 7] = IO.onOk (writeBytes path [7]) 184 (_ : IO.pure (ok 1 t)) 185 physical path logPath [20 3 0] = IO.pure (ok 42 t) 186 physical path logPath [30 4 [7 42]] = IO.onOk (IO.encodeUTF8 "published 7 at 42\n") 187 (bytes : IO.onOk (writeBytes logPath bytes) (_ : IO.pure (ok 1 t))) 188 physical _ _ event = IO.pure (err [95 event] t) 189 190 executeIO path logPath action stack = (let 191 resumeIO value [] = IO.pure (ok value t) 192 resumeIO value [k | rest] = executeIO path logPath (k value) rest 193 resumeIO _ _ = IO.pure (err [94] t) 194 in case action of 195 (100, value) = resumeIO value stack 196 (101, (first, k)) = executeIO path logPath first (pair k stack) 197 (102, (event, k)) = (IO.bind (physical path logPath event) 198 (reply : executeIO path logPath (k reply) stack)) 199 (103, diagnostic) = IO.pure (err diagnostic t) 200 _ = IO.pure (err [94] t)) 201 aFilesystem path logPath = IO.io (executeIO path logPath (publishA (services 11) 7) []) 202 bFilesystem path logPath = IO.io (executeIO path logPath (handlers 11 (publishB 7)) []) 203 204 -- C: explicit handler scopes, interpreted with an environment and continuation 205 -- stack. Application functions (publishB/copyB/repeatB) are unchanged. 206 -- 104 = scope ([logical instance, handler function], body). 207 -- Handler functions run in their installation environment (outside themselves 208 -- and intervening inner scopes); request continuations resume in the caller's 209 -- environment. This is the same lexical handling rule as B's tree rewriting. 210 scope instance handler body = pair 104 (pair [instance handler] body) 211 cRoute instance backend body = scope instance (op arg : request backend op arg) body 212 cHandlers store body = cRoute 3 30 (cRoute 2 20 (cRoute 1 store body)) 213 cLogStore body = scope 1 (op arg : do seq 214 operation 3 4 [op arg] 215 request 1 op arg) body 216 217 -- Look up the nearest matching handler AND its outer environment. Returning 218 -- that suffix is essential: emitted requests must not re-enter this handler. 219 findHandler wanted [[instance handler] | outer] = (lazyBool 220 (_ : pair handler outer) 221 (_ : findHandler wanted outer) 222 (equal? wanted instance)) 223 findHandler _ _ = t 224 225 -- Normalize only up to the next physical request. No recursive transformation 226 -- of the body at scope installation, nor per-handler rewriting of bind nodes. 227 -- Stack frames save [caller environment, continuation]. Scope exit uses ret as 228 -- an identity continuation to restore the outer environment even without bind. 229 normalize action environment stack = (let 230 resume value [] = ret value 231 resume value [[saved k] | rest] = normalize (k value) saved rest 232 resume _ _ = stop [94] 233 dispatch event{[instance op arg]} k = (case findHandler instance environment of 234 (handler, outer) = normalize (handler op arg) outer (pair [environment k] stack) 235 _ = pair 102 (pair event (reply : normalize (k reply) environment stack))) 236 dispatch _ _ = stop [94] 237 in case action of 238 (100, value) = resume value stack 239 (101, (first, k)) = normalize first environment (pair [environment k] stack) 240 (102, (event, k)) = dispatch event k 241 (103, diagnostic) = stop diagnostic 242 (104, (entry, body)) = normalize body (pair entry environment) (pair [environment ret] stack) 243 _ = stop [94]) 244 runC action script = run (normalize action [] []) script 245 cPublish script = runC (cHandlers 11 (publishB 7)) script 246 cLogged script = runC (cHandlers 11 (cLogStore (publishB 7))) script 247 cCopy script = runC (cRoute 5 12 (cRoute 4 11 (copyB 7))) script 248 cTwice script = runC (cHandlers 11 (twiceB publishB)) script 249 cOverride script = runC (cHandlers 11 (cRoute 1 12 (publishB 7))) script 250 cPinned script = (let 251 publisher artifact = cRoute 1 11 (publishB artifact) 252 in runC (cHandlers 11 (cRoute 1 12 (publisher 7))) script) 253 cMissing script = runC (cRoute 3 30 (cRoute 2 20 (publishB 7))) script 254 cWrap [] action = action 255 cWrap [id | rest] action = cRoute id 99 (cWrap rest action) 256 cWrap _ action = action 257 cBench iterations depth script = runC (cRoute 2 20 (cWrap depth (repeatB iterations))) script 258 cFilesystem path logPath = IO.io (executeIO path logPath (normalize (cHandlers 11 (publishB 7)) [] []) []) 259 260 -- Scope controls, with independently specified traces in Python. B and C must 261 -- agree on routing semantics, not merely on the ordinary application workload. 262 bRestore script = run (handlers 11 (do seq 263 route 1 12 (operation 1 1 7) 264 operation 1 1 8)) script 265 cRestore script = runC (cHandlers 11 (do seq 266 cRoute 1 12 (operation 1 1 7) 267 operation 1 1 8)) script 268 -- The handler for 1 emits role 2 into its OUTER environment, not the caller's 269 -- inner role-2 override. This distinguishes lexical from dynamic dispatch. 270 bEmission script = run (route 2 11 (route 1 2 (route 2 12 (operation 1 1 7)))) script 271 cEmission script = runC (cRoute 2 11 (cRoute 1 2 (cRoute 2 12 (operation 1 1 7)))) script 272 bChain script = run (route 11 12 (route 1 11 (operation 1 1 7))) script 273 cChain script = runC (cRoute 11 12 (cRoute 1 11 (operation 1 1 7))) script 274 bNoReentry script = run (route 1 11 (route 1 1 (operation 1 1 7))) script 275 cNoReentry script = runC (cRoute 1 11 (cRoute 1 1 (operation 1 1 7))) script 276 -- Logging installed outside the lowering handler must NOT intercept it. 277 bOuterLog script = run (route 3 30 (logStore (handlers 11 (publishB 7)))) script 278 cOuterLog script = runC (cRoute 3 30 (cLogStore (cHandlers 11 (publishB 7)))) script 279 -- A physical request bypasses logical scopes but its continuation retains them. 280 bForward script = run (route 1 12 (do seq 281 service 11 1 7 282 operation 1 1 8)) script 283 cForward script = runC (cRoute 1 12 (do seq 284 service 11 1 7 285 operation 1 1 8)) script 286 287 -- Application benchmark: distinct artifact IDs, all new in the supplied script. 288 -- Same loop and publisher functions; only dependency installation differs. 289 publishMany publisher [] = ret 0 290 publishMany publisher [artifact | rest] = seq (publisher artifact) (_ : publishMany publisher rest) 291 publishMany _ _ = stop [94] 292 aPublishBench artifacts depth script = run (publishMany (publishA (services 11)) artifacts) script 293 bPublishBench artifacts depth script = run (handlers 11 (wrap depth (publishMany publishB artifacts))) script 294 cPublishBench artifacts depth script = runC (cHandlers 11 (cWrap depth (publishMany publishB artifacts))) script 295 296 -- Returning an inert action does not capture the handler environment. The 297 -- action is later executed in the consumer's scope (unlike explicit pinning). 298 bEscaped script = run (handlers 11 (seq (route 1 12 (ret (operation 1 1 7))) (action : action))) script 299 cEscaped script = runC (cHandlers 11 (seq (cRoute 1 12 (ret (operation 1 1 7))) (action : action))) script 300 301 -- D: routing and scripted execution fused in one machine. The environment, 302 -- handler functions, application trees, and physical request protocol are C's. 303 -- Linear lookup is deliberately unchanged to isolate the effect of fusion. 304 executeD action environment stack script reversed = (let 305 finish diagnostic = [(err diagnostic t) script (reverse reversed)] 306 resume value [] = [(ok value t) script (reverse reversed)] 307 resume value [[saved k] | rest] = executeD (k value) saved rest script reversed 308 resume _ _ = finish [94] 309 consume event k [[expected reply] | rest] = (lazyBool 310 (_ : executeD (k reply) environment stack rest (pair event reversed)) 311 (_ : [(err [92 event expected] t) script (reverse (pair event reversed))]) 312 (equal? event expected)) 313 consume event _ _ = [(err [93 event] t) script (reverse (pair event reversed))] 314 physicalD event{[11 op arg]} k = consume event k script 315 physicalD event{[12 op arg]} k = consume event k script 316 physicalD event{[20 op arg]} k = consume event k script 317 physicalD event{[30 op arg]} k = consume event k script 318 physicalD event _ = finish [95 event] 319 dispatch event{[instance op arg]} k = (case findHandler instance environment of 320 (handler, outer) = executeD (handler op arg) outer (pair [environment k] stack) script reversed 321 _ = physicalD event k) 322 dispatch _ _ = finish [94] 323 in case action of 324 (100, value) = resume value stack 325 (101, (first, k)) = executeD first environment (pair [environment k] stack) script reversed 326 (102, (event, k)) = dispatch event k 327 (103, diagnostic) = finish diagnostic 328 (104, (entry, body)) = executeD body (pair entry environment) (pair [environment ret] stack) script reversed 329 _ = finish [94]) 330 runD action script = executeD action [] [] script [] 331 332 -- Explicit source state belongs to this sequential test interpreter, not a 333 -- mutable native slot. Every adapter returns [reply nextState]. No child-task 334 -- sharing or resource guarantees are implied by this testing accumulator. 335 executeDStateIO adapter state action environment stack = let 336 finish reply = IO.pure [reply state] 337 resume value [] = finish (ok value t) 338 resume value [[saved k] | rest] = executeDStateIO adapter state (k value) saved rest 339 resume _ _ = finish (err [94] t) 340 dispatch event{[instance op arg]} k = case findHandler instance environment of 341 (handler, outer) = executeDStateIO adapter state (handler op arg) outer (pair [environment k] stack) 342 _ = IO.bind (adapter state event) (result : case result of 343 [reply nextState] = executeDStateIO adapter nextState (k reply) environment stack 344 _ = IO.fail "Invalid test adapter state reply") 345 dispatch _ _ = finish (err [94] t) 346 in case action of 347 (100, value) = resume value stack 348 (101, (first, k)) = executeDStateIO adapter state first environment (pair [environment k] stack) 349 (102, (event, k)) = dispatch event k 350 (103, diagnostic) = finish (err diagnostic t) 351 (104, (entry, body)) = executeDStateIO adapter state body (pair entry environment) (pair [environment ret] stack) 352 _ = finish (err [94] t) 353 executeDIO adapter action environment stack = IO.bind 354 (executeDStateIO (state event : IO.bind (adapter event) (reply : IO.pure [reply state])) 355 t action environment stack) 356 (result : case result of 357 [reply _] = IO.pure reply 358 _ = IO.fail "Invalid test interpreter state reply") 359 360 dFilesystem path logPath = IO.io (executeDIO (physical path logPath) (cHandlers 11 (publishB 7)) [] []) 361 362 -- D entrypoints differ only in the chosen interpreter. 363 dPublish script = runD (cHandlers 11 (publishB 7)) script 364 dLogged script = runD (cHandlers 11 (cLogStore (publishB 7))) script 365 dCopy script = runD (cRoute 5 12 (cRoute 4 11 (copyB 7))) script 366 dTwice script = runD (cHandlers 11 (twiceB publishB)) script 367 dOverride script = runD (cHandlers 11 (cRoute 1 12 (publishB 7))) script 368 dPinned script = (let 369 publisher artifact = cRoute 1 11 (publishB artifact) 370 in runD (cHandlers 11 (cRoute 1 12 (publisher 7))) script) 371 dMissing script = runD (cRoute 3 30 (cRoute 2 20 (publishB 7))) script 372 dBench iterations depth script = runD (cRoute 2 20 (cWrap depth (repeatB iterations))) script 373 dRestore script = runD (cHandlers 11 (do seq 374 cRoute 1 12 (operation 1 1 7) 375 operation 1 1 8)) script 376 dEmission script = runD (cRoute 2 11 (cRoute 1 2 (cRoute 2 12 (operation 1 1 7)))) script 377 dChain script = runD (cRoute 11 12 (cRoute 1 11 (operation 1 1 7))) script 378 dNoReentry script = runD (cRoute 1 11 (cRoute 1 1 (operation 1 1 7))) script 379 dOuterLog script = runD (cRoute 3 30 (cLogStore (cHandlers 11 (publishB 7)))) script 380 dForward script = runD (cRoute 1 12 (do seq 381 service 11 1 7 382 operation 1 1 8)) script 383 dPublishBench artifacts depth script = runD (cHandlers 11 (cWrap depth (publishMany publishB artifacts))) script 384 dEscaped script = runD (cHandlers 11 (seq (cRoute 1 12 (ret (operation 1 1 7))) (action : action))) script