consumer_effect_compose.tri (3861B)
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 8 -- Operation trace is host IO state, independent of application retained state. 9 record name argument = bind get (trace : put (pair (pair name argument) trace)) 10 one argument = bind (record "One" argument) (_ : pure (ok argument t)) 11 two argument = (bind (record "Two" argument) (_ : lazyBool 12 (_ : pure (err "offline" t)) (_ : pure (ok argument t)) 13 (equal? (fst argument) 2))) 14 twoSuccess argument = bind (record "Two" argument) (_ : pure (ok argument t)) 15 operations = [(pair "One" one) (pair "Two" two)] 16 successOperations = [(pair "One" one) (pair "Two" twoSuccess)] 17 reference rows = map (row : pair (fst row) (fst (snd (snd row)))) rows 18 lexical rows = map (row : pair (fst row) (S.makeConsumer t (L.lWorker t (fst (snd row))))) rows 19 expectedOutcome = ok (pair (pair (pair 1 11) (pair 1 11)) (pair 91 "offline")) t 20 expectedTrace = [(pair "One" (pair 1 11)) (pair "Two" (pair 1 11)) 21 (pair "One" (pair 2 22)) (pair "Two" (pair 2 22))] 22 named name names = any? (candidate : equal? candidate name) names 23 owned names receivers = filter (row : named (fst row) names) receivers 24 innerPackage receivers = resultOr t (E.makePackage "inner" 25 (owned ["inner" "innerSecond" "innerEnd"] receivers) t) 26 rootPackage receivers entry = resultOr t (E.makePackage entry 27 (filter (row : not? (named (fst row) ["inner" "innerSecond" "innerEnd" "workerFailure"])) receivers) 28 [(pair "inner" (innerPackage receivers)) 29 (pair "workerFailure" (resultOr t (E.makePackage "workerFailure" 30 (owned ["workerFailure"] receivers) t)))]) 31 runCaseUsing step receivers handlers entry = (bind (put t) (_ : 32 bind (E.runWithFault (diagnostic : pure (pair E.faultTag diagnostic)) step handlers (rootPackage receivers entry) 7 91) (result : 33 bind get (trace : pure (pair result (reverse trace)))))) 34 runCase step receivers entry = runCaseUsing step receivers operations entry 35 expectedSuccess = ok (pair (pair (pair 1 11) (pair 1 11)) 36 (pair 91 (pair (pair 2 22) (pair 2 22)))) t 37 errorCase actual message = (let value = fst actual in let detail = E.faultDetail (snd value) in 38 foldl and? true [(equal? (fst value) E.faultTag) 39 (or? (equal? detail message) (equal? (fst detail) message)) (equal? (snd actual) t)]) 40 checkCases step receivers = (bind (runCase step receivers "outer") (nested : 41 bind (runCase step receivers "unresolved") (unresolved : 42 bind (runCase step receivers "nestedWorkerFailure") (workerFailure : 43 bind (runCase step receivers "malformed") (malformed : 44 bind (runCase step receivers "badOutcome") (badOutcome : 45 bind (runCase step receivers "selected") (selected : 46 bind (runCaseUsing step receivers successOperations "outer") (success : 47 pure (pair nested (foldl and? true [ 48 (equal? nested (pair expectedOutcome expectedTrace)) 49 (errorCase unresolved "unknown receiver") 50 (errorCase workerFailure "no matching consumer rule") 51 (errorCase malformed "invalid command") 52 (errorCase badOutcome "invalid returned Result") 53 (equal? selected (pair (ok 42 t) t)) 54 (equal? success (pair expectedSuccess expectedTrace))])))))))))) 55 check rows = (bind (checkCases S.runConsumer (reference rows)) (ref : 56 bind (checkCases L.lEffectStep (lexical rows)) (lex : 57 putStrLn (matchBool "consumer-effect-compose-ok" "consumer-effect-compose-DIFFER" 58 (and? (equal? ref lex) (snd lex)))))) 59 main = io (onResult_ (readFile "test/consumer_effect_compose.scp") 60 (_ : putStrLn "consumer-effect-compose-source-error") 61 (source : lazyResult 62 (_ _ : putStrLn "consumer-effect-compose-compile-error") 63 (rows _ : check rows) 64 (U.compileScpUnit source t))) 65 main