consumer_effect_scopes.tri (6872B)
1 !import "prelude" !Local 2 !import "io" !Local 3 !import "consumers.structural" S 4 !import "consumers.lexical-worker" L 5 !import "consumers.unit-compile" U 6 !import "consumers.effect-compose" E 7 !import "consumers.effect-packages" Packages 8 9 reference rows = map (row : pair (fst row) (fst (snd (snd row)))) rows 10 lexical rows = map (row : pair (fst row) (S.makeConsumer t (L.lWorker t (fst (snd row))))) rows 11 package rows helpers = resultOr t (E.makePackage "entry" rows helpers) 12 -- Factories own whole source units. Caller wiring binds public dependencies. 13 leaf rows = package rows t 14 helper rows dependency = package rows [(pair "dep" dependency)] 15 caller rows service dependency = package rows [(pair "service" service) (pair "dep" dependency)] 16 record argument = bind get (trace : put (pair argument trace)) 17 echo argument = bind (record argument) (_ : pure (ok argument t)) 18 operations = [(pair "Echo" echo)] 19 runCase step scope input state = (bind (put t) (_ : 20 bind (E.runWithFault (diagnostic : pure (pair E.faultTag diagnostic)) step operations scope input state) (result : 21 bind get (trace : pure (pair result (reverse trace)))))) 22 leafValue input state = pair "leaf" (pair input state) 23 helperRequest value state = pair value state 24 helperValue value state = pair "helper" (pair (helperRequest value state) state) 25 callerRequest value state = pair value state 26 callerValue label value state = pair label (pair (callerRequest value state) state) 27 expected label value state prefix = (pair 28 (ok (callerValue label (helperValue value state) state) t) 29 (append prefix [(helperRequest value state) (callerRequest (helperValue value state) state)])) 30 faultCase actual kind message = (let value = fst actual in let diagnostic = snd value in 31 let detail = E.faultDetail diagnostic in foldl and? true [ 32 (equal? (fst value) E.faultTag) (equal? (E.faultKind diagnostic) kind) 33 (or? (equal? detail message) (equal? (fst detail) message)) (equal? (snd actual) t)]) 34 constructors rows dependency = (let row = fst rows in foldl and? true [ 35 (equal? (E.makePackage "entry" [row row] t) (err "duplicate package binding" t)) 36 (equal? (E.makePackage "entry" rows [(pair "dep" dependency) (pair "dep" dependency)]) 37 (err "duplicate package binding" t)) 38 (equal? (E.makePackage "absent" rows t) (err "unknown package entry" t)) 39 (equal? (E.makePackage "entry" (t t) t) (err "improper package registry" t)) 40 (equal? (E.makePackage "entry" [t] t) (err "invalid package registry row" t)) 41 (equal? (E.makePackage "entry" rows [(pair "dep" t)]) (err "invalid package registry value" t)) 42 (equal? (E.packageEntry dependency) "entry")]) 43 checkBackend step convert callerRows secondCallerRows helperRows leafRows constantRows escapeReceiverRows escapeHelperRows = 44 (let child = leaf (convert leafRows) in 45 let service = helper (convert helperRows) child in 46 let external = leaf (convert constantRows) in 47 let first = caller (convert callerRows) service external in 48 let second = caller (convert secondCallerRows) service external in 49 let substituted = (caller (convert callerRows) 50 (helper (convert helperRows) (leaf (convert constantRows))) child) in 51 let badReceiver = caller (convert callerRows) (leaf (convert escapeReceiverRows)) child in 52 let badHelper = caller (convert callerRows) (leaf (convert escapeHelperRows)) child in 53 bind (runCase step first 7 91) (a : 54 bind (runCase step second 8 92) (b : 55 bind (runCase step substituted 7 93) (replacement : 56 bind (runCase step badReceiver 7 91) (receiverFailure : 57 bind (runCase step badHelper 7 91) (helperFailure : 58 bind (runCase step t 7 91) (invalid : 59 pure (pair [a b replacement receiverFailure helperFailure invalid] 60 (foldl and? true [ 61 (equal? a (expected "caller" (leafValue 7 91) 91 [7])) 62 (equal? b (expected "secondCaller" (leafValue 8 92) 92 [8])) 63 (equal? replacement (expected "caller" 99 93 t)) 64 (faultCase receiverFailure "resolution" "unknown receiver") 65 (faultCase helperFailure "resolution" "unknown helper") 66 (faultCase invalid "protocol" "invalid effect package") 67 (constructors (convert callerRows) child) 68 -- Inspect the helper-owned dependency and receiver tables. 69 (equal? (map fst (E.packageHelpers service)) ["dep"]) 70 (equal? (map fst (E.packageReceivers child)) ["entry" "resume"])]))))))))) 71 packageDeclarations rows = (foldl and? true [ 72 (equal? (Packages.preparedPackage rows "entry" ["entry" "entry"] t) 73 (err "duplicate package binding" t)) 74 (equal? (Packages.preparedPackage rows "entry" ["missing"] t) 75 (err (pair "unknown owned receiver" "missing") t)) 76 (equal? (Packages.preparedPackage rows "entry" (t t) t) 77 (err "improper receiver ownership declaration" t)) 78 (equal? (Packages.preparedPackage rows "entry" ["resume"] t) 79 (err "unknown package entry" t)) 80 (equal? (Packages.worker rows "missing") (err (pair "unknown configured worker" "missing") t)) 81 (matchResult (_ _ : false) (value _ : L.lWorkerShape? value) (Packages.worker rows "resume"))]) 82 checkOwnership rows = (E.prepare (Packages.preparedPackage rows "entry" ["entry"] t) (scope : 83 bind (runCase L.lPreparedEffectStep scope 7 91) (escaped : 84 pure (foldl and? true [(packageDeclarations rows) 85 (equal? (map fst (E.packageReceivers scope)) ["entry"]) 86 (faultCase escaped "resolution" "unknown receiver")])))) 87 check callerRows secondCallerRows helperRows leafRows constantRows escapeReceiverRows escapeHelperRows = 88 (bind (checkBackend S.runConsumer reference callerRows secondCallerRows helperRows leafRows constantRows 89 escapeReceiverRows escapeHelperRows) (ref : 90 bind (checkBackend L.lEffectStep lexical callerRows secondCallerRows helperRows leafRows constantRows 91 escapeReceiverRows escapeHelperRows) (lex : 92 bind (checkOwnership leafRows) (ownership : 93 putStrLn (matchBool "consumer-effect-scopes-ok" "consumer-effect-scopes-DIFFER" 94 (foldl and? true [(equal? ref lex) (snd lex) ownership])))))) 95 load name continuation = (onResult_ (readFile (append "test/fixtures/effect-scopes/" name)) 96 (_ : putStrLn "consumer-effect-scopes-source-error") 97 (source : lazyResult (_ _ : putStrLn "consumer-effect-scopes-compile-error") 98 (rows _ : continuation rows) (U.compileScpUnit source t))) 99 main = io (load "caller.scp" (callerRows : 100 load "caller-two.scp" (secondCallerRows : load "helper.scp" (helperRows : load "leaf.scp" (leafRows : 101 load "constant.scp" (constantRows : load "escape-receiver.scp" (escapeReceiverRows : 102 load "escape-helper.scp" (escapeHelperRows : 103 check callerRows secondCallerRows helperRows leafRows constantRows escapeReceiverRows escapeHelperRows)))))))) 104 main