tricu

cps-worker.tri (4729B)

---

 !import prelude *
 !import consumers_structural as S
 !import consumers_lowerings_specialize as P
 !export *
 -- Bounded generic SCP lowering to CPS worker functions. This is not the
 -- generic interpreter: finite rules and output templates compile to functions.
 -- Workers use (input, success, failure); errors are built only at the edge.
 
 slotTail next bindings = next (snd bindings)
 slot_ self slots name = (lazyList (_ : err "unknown capture" t)
   (slot rest : lazyBool (_ : ok fst t)
     (_ : bindResult (self rest name) (next _ : ok (slotTail next) t))
     (equal? slot name)) slots)
 slot slots name = y slot_ slots name
 
 makeFork left right bindings recur invoke success failure =
   left bindings recur invoke (a : right bindings recur invoke (b : success (pair a b)) failure) failure
 makeStem child bindings recur invoke success failure =
   child bindings recur invoke (a : success (t a)) failure
 makeRecur nextInput nextState bindings recur invoke success failure =
   nextInput bindings recur invoke
     (input : nextState bindings recur invoke
       (state : recur input state success failure) failure) failure
 makeCall worker input receiver bindings recur invoke success failure =
   worker bindings recur invoke
     (target : input bindings recur invoke
       (argument : invoke target argument
         (returned : receiver (pair returned bindings) recur invoke success failure)
         failure) failure) failure
 makeEqual left right bindings recur invoke success failure =
   left bindings recur invoke
     (a : right bindings recur invoke
       (b : success (equal? a b)) failure) failure
 
 output_ self output slots = matchPair (tag payload :
   lazyBool (_ : ok (bindings recur invoke success failure : success payload) t)
     (_ : lazyBool (_ : bindResult (slot slots payload) (get _ :
       ok (bindings recur invoke success failure : success (get bindings)) t))
       (_ : lazyBool (_ : matchPair (left right : bindResult (self left slots)
         (a _ : bindResult (self right slots) (b _ : ok (makeFork a b) t))) payload)
         (_ : lazyBool (_ : matchPair (nextInput nextState : bindResult (self nextInput slots)
           (a _ : bindResult (self nextState slots) (b _ : ok (makeRecur a b) t))) payload)
           (_ : lazyBool (_ : matchPair (worker more : matchPair (argument continuation : matchPair
             (returnSlot receiver : bindResult (self worker slots) (a _ :
               bindResult (self argument slots) (b _ :
                 bindResult (self receiver (pair returnSlot slots)) (c _ :
                   ok (makeCall a b c) t)))) continuation) more) payload)
             (_ : lazyBool (_ : bindResult (self payload slots) (child _ : ok (makeStem child) t))
               (_ : lazyBool (_ : err "unsupported output form in CPS worker" t)
                 (_ : lazyBool (_ : matchPair (left right : bindResult (self left slots)
                   (a _ : bindResult (self right slots) (b _ : ok (makeEqual a b) t))) payload)
                   (_ : err "unsupported output form in CPS worker" t) (equal? tag 8)) (equal? tag 6)) (equal? tag 5))
             (equal? tag 4)) (equal? tag 3)) (equal? tag 2))
       (equal? tag 1)) (equal? tag 0)) output
 compileOutput output slots = y output_ output slots
 
 branch inputMatcher stateMatcher result fallback input state recur invoke success failure =
   lazyMaybe (_ : fallback input state recur invoke success failure)
     (inputBindings : lazyMaybe (_ : fallback input state recur invoke success failure)
       (bindings : result bindings recur invoke success failure)
       (stateMatcher state inputBindings)) (inputMatcher input t)
 rules_ self rules = (lazyList (_ : ok (input state recur invoke success failure : failure "no matching consumer rule") t)
   (rule rest : matchPair (inputPattern more : matchPair (statePattern template :
     bindResult (self rest) (fallback _ : bindResult
       (compileOutput template (P.patternSlots statePattern (P.patternSlots inputPattern t)))
       (result _ : ok (branch (P.indexedPattern inputPattern)
         (P.indexedPattern statePattern) result fallback) t))) more) rule) rules)
 compileRules rules = y rules_ rules
 compile consumer = bindResult (compileRules (snd consumer)) (function _ : ok (S.makeConsumer (fst consumer) function) t)
 
 run_ self input state program success failure = (snd program) input state (nextInput nextState ok fail : self nextInput nextState program ok fail) (worker argument ok fail : worker argument ok fail) success failure
 run program input success failure = y run_ input (fst program) program success failure
 makeWorker program = (input success failure : run program input success failure)
 runChecked program input = run program input (value : ok value t) (message : err message t)