179aa28c5e59df55dc1fe9abdf616b509e8f6cb485ba5e615d956aadfd1d4a54.tri (8030B)
1 !import prelude * 2 !import parser * 3 !import source_core * 4 !import source_pattern * 5 !import source_staging_experiment as S 6 !export * 7 -- Source-only consumed-input experiment; not in the canonical module map. 8 9 stagedListMarker = "tricu.experimental.stageList.v1" 10 stagedNextMarker = "tricu.experimental.stageNext.v1" 11 stagedListBindings = [(pair "stageList" stagedListMarker) (pair "stageNext" stagedNextMarker)] 12 stagedListMarker? node marker = and? (equal? (sourceCoreKind node) sourceCoreExternalKind) (equal? (sourceCorePayload node) marker) 13 stagedListError label node = err (parserDiagnostic 48 label t (sourceCoreStart node) t) node 14 15 -- Finite application-spine inspection, returning arguments in source order. 16 stagedListOne node marker = (lazyBool 17 (_ : lazyBool (_ : just (sourceCorePayload node)) (_ : nothing) 18 (stagedListMarker? (fst (sourceCorePayload node)) marker)) 19 (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind)) 20 stagedListTwo node marker = (lazyBool 21 (_ : lazyMaybe (_ : nothing) 22 (first : just (pair (snd first) (snd (sourceCorePayload node)))) 23 (stagedListOne (fst (sourceCorePayload node)) marker)) 24 (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind)) 25 stagedListThree node marker = (lazyBool 26 (_ : lazyMaybe (_ : nothing) 27 (first : just (pair first (snd (sourceCorePayload node)))) 28 (stagedListTwo (fst (sourceCorePayload node)) marker)) 29 (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind)) 30 stagedListFour node = (lazyBool 31 (_ : lazyMaybe (_ : nothing) 32 (first : just (pair first (snd (sourceCorePayload node)))) 33 (stagedListThree (fst (sourceCorePayload node)) stagedListMarker)) 34 (_ : nothing) (equal? (sourceCoreKind node) sourceCoreApplyKind)) 35 36 -- Force dependency derived from an actual consumed tree, always Leaf once 37 -- its constructor is available. Unlike a constant token this blocks building 38 -- closed callback work while the list input remains abstract. 39 stagedListToken index = spApp4 (spLit triage) (spLit t) (spLam (spLit t)) (spLam (spLam (spLit t))) (spVar index) 40 stagedListProtect body index = S.stageFinish (spApp (S.stageThunk body) (stagedListToken index)) 41 stagedListDone body = (stagedListProtect 42 (y S.stageShift_ (y S.stageShift_ (y S.stageBody_ body false 0) 1) 1) 1) 43 -- Direct worker layout inside Fork's head/tail lambdas: 44 -- tail=0, head=1, state=2, input=3, self=4, outer binders from 5. 45 -- Building this finite core directly avoids a second pattern/capture lowering 46 -- pass over compiler-generated callbacks. 47 stagedListMapStep_ self node depth = (let kind = sourceCoreKind node in let payload = sourceCorePayload node in 48 lazyBool 49 (_ : spVar (lazyBool (_ : payload) 50 (_ : lazyBool (_ : add depth 2) 51 (_ : lazyBool (_ : payload) (_ : add payload 3) (equal? payload (succ depth))) 52 (equal? payload depth)) (lt_? payload depth))) 53 (_ : lazyBool 54 (_ : spApp2 (spVar (add depth 4)) (spVar depth) (self payload depth)) 55 (_ : lazyBool 56 (_ : S.stageBranch (self (fst payload) depth) 57 (self (fst (snd payload)) depth) (self (snd (snd payload)) depth)) 58 (_ : lazyBool 59 (_ : spApp (self (fst payload) depth) (self (snd payload) depth)) 60 (_ : lazyBool 61 (_ : spLam (self payload (succ depth))) 62 (_ : lazyBool 63 (_ : sourceCoreList (map (child : self child depth) payload) t t) 64 (_ : node) (equal? kind sourceCoreListKind)) 65 (equal? kind sourceCoreLambdaKind)) (equal? kind sourceCoreApplyKind)) 66 (equal? kind 96)) (equal? kind 97)) (equal? kind sourceCoreBoundKind)) 67 stagedListStep body = stagedListProtect (y S.stageBody_ (y stagedListMapStep_ body 0) false 0) 3 68 stagedListWorker done step = (spLam (spLam (spLam (spApp4 (spLit triage) 69 (stagedListDone done) 70 (spLam (spShift (stagedListDone done))) 71 (spLam (spLam (stagedListStep step))) (spVar 1))))) 72 stagedListLower done step = (ok (sourceCoreNode 98 (spLam (spApp2 73 (spApp (spLit y) (spShift2 (stagedListWorker done step))) (spVar 1) (spVar 0))) t t) t) 74 75 -- mode 0 = outside; 1 = done; 2 = step; 3 = condition/next-state. 76 -- Initially require inline callbacks and reject nested loops. This preserves 77 -- lexical ownership without guessing callback bodies from arbitrary trees. 78 stagedListCallbacks self parts node = (let done = snd (fst parts) in let step = snd parts in 79 lazyBool 80 (_ : lazyBool 81 (_ : lazyBool 82 (_ : lazyResult (problem rest : err problem rest) 83 (input rest : lazyResult (problem rest : err problem rest) 84 (state rest : lazyResult (problem rest : err problem rest) 85 (doneBody rest : lazyResult (problem rest : err problem rest) 86 (stepBody rest : lazyResult (problem rest : err problem rest) 87 (function rest : ok (spApp2 function input state) t) 88 (stagedListLower doneBody stepBody)) 89 (self (sourceCorePayload (sourceCorePayload step)) 2)) 90 (self (sourceCorePayload done) 1)) 91 (self (snd (fst (fst parts))) 0)) (self (fst (fst (fst parts))) 0)) 92 (_ : stagedListError "stageList step requires inline head/state binders" node) 93 (equal? (sourceCoreKind (sourceCorePayload step)) sourceCoreLambdaKind)) 94 (_ : stagedListError "stageList step requires inline head/state binders" node) 95 (equal? (sourceCoreKind step) sourceCoreLambdaKind)) 96 (_ : stagedListError "stageList done requires an inline state binder" node) 97 (equal? (sourceCoreKind done) sourceCoreLambdaKind)) 98 stagedListChildren_ self nodes lower mode = (lazyList (_ : ok [] t) 99 (head tail : lazyResult (problem rest : err problem rest) 100 (first rest : lazyResult (problem rest : err problem rest) 101 (remaining rest : ok (pair first remaining) t) (self tail lower mode)) (lower head mode)) nodes) 102 stagedListChildren nodes lower mode = y stagedListChildren_ nodes lower mode 103 stagedListPlain self node mode = (let kind = sourceCoreKind node in let payload = sourceCorePayload node in 104 lazyBool 105 (_ : lazyResult (problem rest : err problem rest) 106 (condition rest : lazyResult (problem rest : err problem rest) 107 (yes rest : lazyResult (problem rest : err problem rest) 108 (no rest : ok (S.stageBranch condition yes no) t) (self (snd (snd payload)) mode)) 109 (self (fst (snd payload)) mode)) (self (fst payload) (lazyBool (_ : 0) (_ : 3) (isZero_? mode)))) 110 (_ : lazyBool 111 (_ : lazyResult (problem rest : err problem rest) 112 (left rest : lazyResult (problem rest : err problem rest) 113 (right rest : ok (spApp left right) t) (self (snd payload) mode)) (self (fst payload) mode)) 114 (_ : lazyBool 115 (_ : lazyResult (problem rest : err problem rest) 116 (body rest : ok (spLam body) t) (self payload mode)) 117 (_ : lazyBool 118 (_ : lazyResult (problem rest : err problem rest) 119 (items rest : ok (sourceCoreList items t t) t) (stagedListChildren payload self mode)) 120 (_ : lazyBool 121 (_ : stagedListError "fully applied stageList input state done step or stageNext state" node) 122 (_ : ok node t) 123 (or? (stagedListMarker? node stagedListMarker) (stagedListMarker? node stagedNextMarker))) 124 (equal? kind sourceCoreListKind)) (equal? kind sourceCoreLambdaKind)) 125 (equal? kind sourceCoreApplyKind)) (equal? kind 96)) 126 stagedListRewrite_ self node mode = (lazyMaybe 127 (_ : lazyMaybe 128 (_ : stagedListPlain self node mode) 129 (parts : lazyBool 130 (_ : lazyResult (problem rest : err problem rest) 131 (state rest : ok (S.stageRecur state) t) (self (snd parts) 3)) 132 (_ : stagedListError "stageNext belongs only to a stageList step body" node) 133 (equal? mode 2)) (stagedListOne node stagedNextMarker)) 134 (parts : lazyBool (_ : stagedListCallbacks self parts node) 135 (_ : stagedListError "nested stageList is not supported in callbacks" node) (isZero_? mode)) 136 (stagedListFour node)) 137 stagedListRewrite node = y stagedListRewrite_ node 0