tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

consumer_effect_results.tri (5215B)

      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 reference rows = map (row : pair (fst row) (fst (snd (snd row)))) rows
      9 lexical rows = map (row : pair (fst row) (S.makeConsumer t (L.lWorker t (fst (snd row))))) rows
     10 package rows helpers = E.makePackage "entry" rows helpers
     11 capture diagnostic = pure (pair E.faultTag diagnostic)
     12 relay value = pure value
     13 invalid value = pure t
     14 success = ok (pair "value" 9) (pair 17 [3])
     15 failure = err (pair "disk" [7 8]) (pair 91 [4])
     16 run step operations scope value = E.runWithFault capture step operations scope value t
     17 fault value kind detail = (and? (equal? (fst value) E.faultTag)
     18   (let diagnostic = snd value in foldl and? true [
     19     (equal? (E.faultKind diagnostic) kind)
     20     (equal? (E.faultDetail diagnostic) detail)
     21     (equal? (E.faultLocation diagnostic) (pair "entry" "entry"))
     22     (equal? (E.faultReturns diagnostic) [(pair "entry" (pair "relay" "resume"))])]))
     23 checkBackend step convert callerRows recoverRows relayRows workerRows = (lazyResult
     24   (_ _ : pure (pair t false))
     25   (dependency _ : lazyResult (_ _ : pure (pair t false))
     26     (caller _ : lazyResult (_ _ : pure (pair t false))
     27       (recovery _ : lazyResult (_ _ : pure (pair t false))
     28         (worker _ : lazyResult (_ _ : pure (pair t false))
     29           (broken _ : bind (run step [(pair "Relay" relay)] caller success) (a :
     30             bind (run step [(pair "Relay" relay)] caller failure) (b :
     31               bind (run step [(pair "Relay" relay)] recovery failure) (c :
     32                 bind (run step [(pair "Relay" invalid)] caller success) (malformed :
     33                   bind (run step t broken success) (workerFailure :
     34                     pure (pair [a b c malformed workerFailure] (foldl and? true [
     35                       (equal? a success) (equal? b failure)
     36                       (equal? (E.resultShape? (pair 1 (pair "value" t))) false)
     37                       (equal? c (ok (pair (pair "disk" [7 8]) (pair 91 [4])) t))
     38                       (fault malformed "protocol" "invalid operation Result")
     39                       (fault workerFailure "worker" "no matching consumer rule")])))))))
     40           (package (convert callerRows) [(pair "relay" worker)]))
     41         (package (convert workerRows) t))
     42       (package (convert recoverRows) [(pair "relay" dependency)]))
     43     (package (convert callerRows) [(pair "relay" dependency)]))
     44   (package (convert relayRows) t)))
     45 checkPreparation = (bind
     46   (E.prepareWithFault capture (err (pair "compile" [4]) [91]) (_ : pure "unexpected")) (value :
     47     let diagnostic = snd value in pure (foldl and? true [
     48       (equal? (fst value) E.faultTag) (equal? (E.faultKind diagnostic) "preparation")
     49       (equal? (E.faultDetail diagnostic) (pair (pair "compile" [4]) [91]))
     50       (equal? (E.faultLocation diagnostic) (pair "prepare" "configuration"))])))
     51 checkMalformedPreparation = (let invalid = pair 1 (pair "unused" t) in
     52   bind (E.prepareWithFault capture invalid (_ : pure "unexpected")) (value :
     53     let diagnostic = snd value in pure (foldl and? true [
     54       (equal? (fst value) E.faultTag) (equal? (E.faultKind diagnostic) "preparation")
     55       (equal? (E.faultDetail diagnostic) (pair "invalid preparation Result" invalid))])))
     56 preparedValid rows = equal? (L.lPrepareEffectReceivers (lexical rows)) (ok (lexical rows) t)
     57 checkPreparedTables = (foldl and? true [
     58   (equal? (L.lPrepareEffectReceivers t) (ok t t))
     59   (equal? (L.lPrepareEffectReceivers (t t)) (err "improper prepared receiver table" t))
     60   (equal? (L.lPrepareEffectReceivers [t]) (err "invalid prepared receiver row" t))
     61   (equal? (L.lPrepareEffectReceivers [(pair "bad" t)]) (err "invalid prepared consumer" t))
     62   (equal? (L.lPrepareEffectReceivers [(pair "bad" (pair t t))])
     63     (err (pair "invalid prepared worker" "bad") t))])
     64 check callerRows recoverRows relayRows workerRows = (bind
     65   (checkBackend S.runConsumer reference callerRows recoverRows relayRows workerRows) (ref :
     66     bind (checkBackend L.lEffectStep lexical callerRows recoverRows relayRows workerRows) (lex :
     67       bind (checkBackend L.lPreparedEffectStep lexical callerRows recoverRows relayRows workerRows) (fast :
     68       bind checkPreparation (prepared : bind checkMalformedPreparation (malformed :
     69         putStrLn (matchBool "consumer-effect-results-ok" "consumer-effect-results-DIFFER"
     70           (foldl and? true [(equal? ref lex) (snd lex) (equal? fast lex) (snd fast)
     71             prepared malformed checkPreparedTables
     72             (preparedValid callerRows) (preparedValid recoverRows)
     73             (preparedValid relayRows) (preparedValid workerRows)]))))))))
     74 load name continuation = (onResult_ (readFile (append "test/fixtures/effect-scopes/" name))
     75   (_ : putStrLn "consumer-effect-results-source-error")
     76   (source : lazyResult (_ _ : putStrLn "consumer-effect-results-compile-error")
     77     (rows _ : continuation rows) (U.compileScpUnit source t)))
     78 main = io (load "result-caller.scp" (callerRows :
     79   load "result-recover.scp" (recoverRows : load "relay.scp" (relayRows :
     80     load "result-worker-fault.scp" (workerRows : check callerRows recoverRows relayRows workerRows)))))
     81 main