effect-compose.tri (7569B)
1 !import prelude * 2 !import io * 3 !import consumers_structural as S 4 !import consumers_effect as E 5 !export * 6 -- Scoped helper-return dispatcher. Packages own receiver tables and explicit 7 -- helper dependencies. 8 9 returnResult result = pair 0 result 10 request = E.request 11 invoke helper input state receiver retained = 12 pair 2 (pair helper (pair input (pair state (pair receiver retained)))) 13 14 -- Tagged ordinary tree: (entry name, (private receivers, helper packages)). 15 -- Preparation supplies trusted package descriptors and compatible workers. 16 packageTag = "scp-effect-package.v1" 17 selfReference = pair "scp-current-package.v1" t 18 ecPair value yes no = triage no (_ : no) yes value 19 packageShape? value = (ecPair value (tag payload : 20 and? (equal? tag packageTag) (ecPair payload (_ rest : 21 ecPair rest (_ _ : true) false) false)) false) 22 packageEntry package = fst (snd package) 23 packageReceivers package = fst (snd (snd package)) 24 packageHelpers package = snd (snd (snd package)) 25 ecRows_ self rows seen packages = (triage (ok t t) 26 (_ : err "improper package registry" t) 27 (row rest : ecPair row (name value : lazyMaybe 28 (_ : lazyBool 29 (_ : self rest (pair (pair name t) seen) packages) 30 (_ : err "invalid package registry value" t) 31 (lazyBool (_ : or? (equal? value selfReference) (packageShape? value)) 32 (_ : ecPair value (_ _ : true) false) packages)) 33 (_ : err "duplicate package binding" t) (E.lookup seen name)) 34 (err "invalid package registry row" t)) rows) 35 ecRows rows packages = y ecRows_ rows t packages 36 makePackage entry receivers helpers = (bindResult (ecRows receivers false) (_ _ : 37 bindResult (ecRows helpers true) (_ _ : lazyMaybe 38 (_ : err "unknown package entry" t) 39 (_ : ok (pair packageTag (pair entry (pair receivers helpers))) t) 40 (E.lookup receivers entry)))) 41 42 -- Native Result: (Leaf or Stem Leaf, (payload, metadata)). Every application boundary 43 -- carries the complete value, including metadata and structured error payloads. 44 resultShape? result = (ecPair result (tag payload : 45 and? (or? (equal? tag false) (equal? tag true)) 46 (ecPair payload (_ _ : true) false)) false) 47 faultTag = "scp-execution-fault.v1" 48 faultKind diagnostic = fst diagnostic 49 faultDetail diagnostic = fst (snd diagnostic) 50 faultLocation diagnostic = fst (snd (snd diagnostic)) 51 faultReturns diagnostic = snd (snd (snd diagnostic)) 52 reportFault diagnostic = abortIO (pair faultTag diagnostic) 53 prepareWithFault faultK prepared use = (lazyBool 54 (_ : lazyResult 55 (problem metadata : faultK (pair "preparation" (pair (pair problem metadata) (pair (pair "prepare" "configuration") t)))) 56 (value _ : use value) prepared) 57 (_ : faultK (pair "preparation" (pair (pair "invalid preparation Result" prepared) 58 (pair (pair "prepare" "configuration") t)))) 59 (resultShape? prepared)) 60 prepare prepared use = prepareWithFault reportFault prepared use 61 ecFrameLocation frame = (pair (packageEntry (fst frame)) 62 (pair (fst (snd (snd frame))) (fst (snd frame)))) 63 ecFault runtime kind detail scope site stack = ((snd (snd runtime)) 64 (pair kind (pair detail (pair 65 (lazyBool (_ : pair (packageEntry scope) site) (_ : pair t site) (packageShape? scope)) 66 (map ecFrameLocation stack))))) 67 -- Frames retain caller package, receiver name, helper alias, resolved worker, 68 -- and state. Diagnostics identify pending returns through these relationships. 69 ecReturn self result scope site stack runtime = (lazyBool 70 (_ : lazyList (_ : pure result) 71 (frame rest : self result runtime (fst (snd (snd (snd frame)))) 72 (snd (snd (snd (snd frame)))) (fst frame) (fst (snd frame)) rest) stack) 73 (_ : ecFault runtime "protocol" "invalid returned Result" scope site stack) 74 (resultShape? result)) 75 ecAwait self payload scope site stack runtime = (ecPair payload 76 (operation rest : ecPair rest 77 (argument more : ecPair more 78 (receiver retained : lazyMaybe 79 (_ : ecFault runtime "resolution" ["unknown receiver" receiver] scope site stack) 80 (program : lazyMaybe 81 (_ : ecFault runtime "resolution" ["unknown operation" operation] scope site stack) 82 (handler : bind (handler argument) (result : lazyBool 83 (_ : self result runtime program retained scope receiver stack) 84 (_ : ecFault runtime "protocol" "invalid operation Result" scope site stack) 85 (resultShape? result))) 86 (E.lookup (fst (snd runtime)) operation)) 87 (E.lookup (packageReceivers scope) receiver)) 88 (ecFault runtime "protocol" "invalid request" scope site stack)) 89 (ecFault runtime "protocol" "invalid request" scope site stack)) 90 (ecFault runtime "protocol" "invalid request" scope site stack)) 91 ecInvoke self payload scope site stack runtime = (ecPair payload 92 (helper rest : ecPair rest 93 (input more : ecPair more 94 (state tail : ecPair tail 95 (receiver retained : lazyMaybe 96 (_ : ecFault runtime "resolution" ["unknown receiver" receiver] scope site stack) 97 (caller : lazyMaybe 98 (_ : ecFault runtime "resolution" ["unknown helper" helper] scope site stack) 99 (binding : let callee = lazyBool (_ : scope) (_ : binding) (equal? binding selfReference) in (lazyBool 100 (_ : lazyMaybe 101 (_ : ecFault runtime "resolution" "unknown package entry" callee (packageEntry callee) stack) 102 (program : self input runtime program state callee (packageEntry callee) 103 (pair (pair scope (pair receiver (pair helper (pair caller retained)))) stack)) 104 (E.lookup (packageReceivers callee) (packageEntry callee))) 105 (_ : ecFault runtime "protocol" "invalid effect package" scope site stack) 106 (packageShape? callee))) 107 (E.lookup (packageHelpers scope) helper)) 108 (E.lookup (packageReceivers scope) receiver)) 109 (ecFault runtime "protocol" "invalid helper invocation" scope site stack)) 110 (ecFault runtime "protocol" "invalid helper invocation" scope site stack)) 111 (ecFault runtime "protocol" "invalid helper invocation" scope site stack)) 112 (ecFault runtime "protocol" "invalid helper invocation" scope site stack)) 113 ecCommand self command scope site stack runtime = (ecPair command 114 (tag payload : lazyBool 115 (_ : ecReturn self payload scope site stack runtime) 116 (_ : lazyBool 117 (_ : ecAwait self payload scope site stack runtime) 118 (_ : lazyBool 119 (_ : ecInvoke self payload scope site stack runtime) 120 (_ : ecFault runtime "protocol" "unknown command" scope site stack) (equal? tag 2)) 121 (equal? tag 1)) 122 (equal? tag 0)) 123 (ecFault runtime "protocol" "invalid command" scope site stack)) 124 ecRun_ self input runtime program state scope site stack = (lazyResult 125 (problem _ : ecFault runtime "worker" problem scope site stack) 126 (command _ : ecCommand self command scope site stack runtime) 127 ((fst runtime) (S.makeConsumer state (snd program)) input)) 128 runWithFault faultK step operations package input state = (let runtime = pair step (pair operations faultK) in 129 lazyBool 130 (_ : lazyMaybe 131 (_ : ecFault runtime "resolution" "unknown package entry" package (packageEntry package) t) 132 (program : y ecRun_ input runtime program state package (packageEntry package) t) 133 (E.lookup (packageReceivers package) 134 (E.receiverFromInput (packageEntry package) input))) 135 (_ : ecFault runtime "protocol" "invalid effect package" package t t) 136 (packageShape? package)) 137 run step operations package input state = (runWithFault 138 reportFault step operations package input state)