tricu

tail-fold.tri (3582B)

---

 !import prelude *
 !import consumers_structural as S
 !import consumers_lowerings_specialize as P
 !export *
 -- Experimental tricu-owned lowering for two-rule list consumers.
 -- Reject unsupported input shapes rather than changing their semantics.
 
 leafRule rule = matchPair (input more : matchPair (state output :
   matchPair (tag payload : lazyBool (_ : just (pair state output))
     (_ : nothing) (equal? tag 1)) input) more) rule
 consRule rule = matchPair (input more : matchPair (state output :
   matchPair (tag children : lazyBool (_ : matchPair (left right :
     matchPair (leftTag leftSlot : matchPair (rightTag rightSlot :
       lazyBool (_ : just (pair (pair leftSlot rightSlot) (pair state output)))
         (_ : nothing) (and? (equal? leftTag 4) (equal? rightTag 4))) right) left) children)
     (_ : nothing) (equal? tag 3)) input) more) rule
 
 -- Inputs are disjoint, so rule order cannot affect this accepted fragment.
 classify first second = (lazyMaybe (_ : lazyMaybe (_ : nothing) (cons : lazyMaybe (_ : nothing)
     (leaf : just (pair leaf cons)) (leafRule second)) (consRule first))
   (leaf : lazyMaybe (_ : nothing) (cons : just (pair leaf cons)) (consRule second))
   (leafRule first))
 
 compileLeaf statePattern output = (state recur invoke : lazyMaybe (_ : err "no matching consumer rule" t) (bindings : (P.indexedOutput output (P.patternSlots statePattern t)) bindings recur invoke) ((P.indexedPattern statePattern) state t))
 compileCons slots statePattern output = (byte rest state recur invoke : matchPair (byteSlot restSlot : lazyMaybe (_ : err "no matching consumer rule" t) (bindings : (P.indexedOutput output (P.patternSlots statePattern (pair restSlot (pair byteSlot t)))) bindings recur invoke) ((P.indexedPattern statePattern) state (pair rest (pair byte t)))) slots)
 compileBranches branches = matchPair (leaf cons : matchPair
   (leafState leafOutput : matchPair (slots more : matchPair
     (consState consOutput : pair (compileLeaf leafState leafOutput)
       (compileCons slots consState consOutput)) more) cons) leaf) branches
 
 -- The only per-byte input dispatch is the actual list constructor. The two
 -- rule functions are prepared before runtime recursion, not parsed per byte.
 loop_ self input state leaf cons = ((selected : selected t) (triage
   (_ : leaf state
     (nextInput nextState : self nextInput nextState leaf cons)
     (worker argument initial : y P.runDirect_ argument worker initial))
   (child : _ : err "no matching consumer rule" t)
   (byte rest : _ : cons byte rest state
     (nextInput nextState : self nextInput nextState leaf cons)
     (worker argument initial : y P.runDirect_ argument worker initial)) input))
 run program input = matchPair (initial branches : matchPair (leaf cons :
   y loop_ input initial leaf cons) branches) program
 -- Compatible with runDirect's (initial, step) protocol. Once invoked, the
 -- fixed-point loop handles its own recurrence, not runDirect's recur callback.
 asDirect program = matchPair (initial branches : matchPair (leaf cons :
   S.makeConsumer initial (input state recur invoke : y loop_ input state leaf cons)) branches) program
 compile consumer = (lazyList (_ : err "tail-fold requires exactly two rules" t) (first rest : lazyList (_ : err "tail-fold requires exactly two rules" t)
     (second extra : lazyList (_ : lazyMaybe
       (_ : err "tail-fold requires leaf and captured cons rules" t)
       (branches : ok (pair (fst consumer) (compileBranches branches)) t)
       (classify first second))
       (_ _ : err "tail-fold requires exactly two rules" t) extra) rest)
   (snd consumer))