base-source.tri (11665B)
1 !import prelude * 2 !import parser as P 3 !import consumers_source as C 4 !import consumers_structural as S 5 !export * 6 -- General structural consumer source: captures, tree patterns/templates, 7 -- first-match rules, recursion, dynamic call/return and tail delegation. 8 -- No map/fold/append/prefix-specific syntax or runtime branch lives here. 9 -- Single-consumer entry points: compileBaseSource and compileBaseSourceLocated 10 -- return authored IR, not executable workers. bs* pieces also serve unit-source; use it 11 -- for multiple definitions, and unit-build for native module headers/imports. 12 13 bsBind name bindings = P.parserMap (updated : pair (S.patCapture (length bindings)) updated) (C.cBind name (length bindings) bindings) 14 -- `as whole pattern` binds the whole value before the child pattern's slots, 15 -- matching the reference matcher and the lexical compiler's binder order. 16 bsAsPattern self bindings = P.parserBind (C.cExpect C.cName) (name : 17 P.parserBind (C.cBind name (length bindings) bindings) (updated : 18 P.parserMap (child : pair (S.patAs (length bindings) (fst child)) (snd child)) 19 (self updated))) 20 bsNamePattern self name bindings = lazyBool (_ : P.parserPure (pair S.patAny bindings)) (_ : lazyBool (_ : P.parserPure (pair S.patLeaf bindings)) (_ : lazyBool (_ : P.parserMap (child : pair (S.patStem (fst child)) (snd child)) (self bindings)) (_ : lazyBool (_ : bsAsPattern self bindings) (_ : bsBind name bindings) (equal? name "as")) (equal? name "stem")) (equal? name "leaf")) (equal? name "_") 21 bsPairPattern self bindings close separator = P.parserBind (self bindings) (left : 22 P.parserThen (C.cExpect separator) 23 (P.parserBind (self (snd left)) (right : 24 P.parserMap (_ : pair (S.patFork (fst left) (fst right)) (snd right)) 25 (C.cExpect close)))) 26 bsPattern_ self input bindings = 27 lazyList (_ : P.parserReplyFail (C.cExpected "pattern" t t) input false false) 28 (token rest : lazyBool 29 (_ : P.parserBind (C.cExpect C.cName) (name : 30 bsNamePattern (other : stream : self stream other) name bindings) input) 31 (_ : lazyBool 32 (_ : P.parserMap (number : pair (S.patLiteral number) bindings) 33 (C.cExpect C.cNumber) input) 34 (_ : lazyBool 35 (_ : P.parserMap (text : pair (S.patLiteral text) bindings) 36 (C.cExpect C.cString) input) 37 (_ : lazyBool 38 (_ : P.parserThen (C.cExpect C.cLeft) (P.parserOr 39 (P.parserMap (_ : pair S.patLeaf bindings) (C.cExpect C.cRight)) 40 (bsPairPattern (other : stream : self stream other) bindings C.cRight C.cBar)) input) 41 (_ : lazyBool 42 (_ : P.parserThen (C.cExpect C.cOpen) (bsPairPattern (other : stream : self stream other) bindings C.cClose C.cComma) input) 43 (_ : P.parserReplyFail (C.cExpected "pattern" (C.cKind token) (C.cStart token)) input false false) 44 (equal? (C.cKind token) C.cOpen)) 45 (equal? (C.cKind token) C.cLeft)) 46 (equal? (C.cKind token) C.cString)) 47 (equal? (C.cKind token) C.cNumber)) 48 (equal? (C.cKind token) C.cName)) 49 input 50 bsPattern bindings = input : y bsPattern_ input bindings 51 52 -- Templates are data, not eager helper calls. The capture introduced by 53 -- call is visible only in its receiver; duplicate names fail compilation. 54 bsPairOutput self bindings close separator = P.parserBind (self bindings) (left : 55 P.parserThen (C.cExpect separator) 56 (P.parserMap (right : S.outFork left right) 57 (P.parserBefore (self bindings) (C.cExpect close)))) 58 bsRecur self bindings = P.parserBind (self bindings) (nextInput : 59 P.parserThen (C.cExpect C.cAt) 60 (P.parserMap (nextState : S.outRecur nextInput nextState) 61 (self bindings))) 62 bsBecome self bindings = P.parserBind (self bindings) (worker : 63 P.parserBind (self bindings) (argument : 64 P.parserThen (C.cExpect C.cAt) 65 (P.parserMap (state : S.outBecome worker argument state) 66 (self bindings)))) 67 bsCall self bindings = P.parserBind (self bindings) (worker : 68 P.parserBind (self bindings) (argument : 69 P.parserThen (C.cWord "as") 70 (P.parserBind (C.cExpect C.cName) (name : 71 P.parserBind (C.cBind name (length bindings) bindings) (updated : 72 P.parserThen (C.cWord "in") 73 (P.parserMap (receiver : S.outCall worker argument 74 (length bindings) receiver) (self updated))))))) 75 -- Parenthesized arms make nested matches unambiguous; each arm starts with 76 -- the outer bindings, and only its body sees that arm's pattern bindings. 77 bsMatchArm self bindings = P.parserBind (bsPattern bindings) (parsed : 78 P.parserThen (C.cExpect C.cArrow) 79 (P.parserMap (body : pair (fst parsed) body) (self (snd parsed)))) 80 bsMatch self bindings = P.parserBind (self bindings) (source : 81 P.parserThen (C.cWord "of") 82 (P.parserThen (C.cExpect C.cOpen) 83 (P.parserBefore 84 (P.parserBind (bsMatchArm self bindings) (first : 85 P.parserMap (rest : S.outMatch source (pair first rest)) 86 (P.parserMany (P.parserThen (C.cExpect C.cBar) 87 (bsMatchArm self bindings))))) 88 (C.cExpect C.cClose)))) 89 -- A source-level shorthand for matching exactly the two Boolean trees. 90 -- In particular, a fork or a stem with a non-leaf child is not true. 91 bsChoose self bindings = P.parserBind (self bindings) (condition : 92 P.parserBind (self bindings) (yes : 93 P.parserMap (no : S.outMatch condition 94 [(pair S.patLeaf no) (pair (S.patStem S.patLeaf) yes)]) 95 (self bindings))) 96 bsEqual self bindings = P.parserBind (self bindings) (left : 97 P.parserMap (right : S.outEqual left right) (self bindings)) 98 bsOutputName self bindings name = 99 lazyBool (_ : bsMatch self bindings) 100 (_ : lazyBool (_ : bsRecur self bindings) 101 (_ : lazyBool (_ : bsCall self bindings) 102 (_ : lazyBool (_ : bsBecome self bindings) 103 (_ : lazyBool (_ : bsChoose self bindings) 104 (_ : lazyBool (_ : bsEqual self bindings) 105 (_ : lazyBool (_ : P.parserMap S.outStem (self bindings)) 106 (_ : lazyBool (_ : P.parserPure (S.outLiteral t)) 107 (_ : C.cReference bindings name) (equal? name "leaf")) 108 (equal? name "stem")) 109 (equal? name "equal")) 110 (equal? name "choose")) 111 (equal? name "become")) 112 (equal? name "call")) 113 (equal? name "recur")) 114 (equal? name "match") 115 bsOutputUsing_ self input bindings reference = 116 lazyList (_ : P.parserReplyFail (C.cExpected "template" t t) input false false) 117 (token rest : lazyBool 118 (_ : P.parserBind (C.cExpect C.cName) (name : 119 bsOutputQualified (other : stream : self stream other reference) bindings reference name (C.cStart token)) input) 120 (_ : lazyBool 121 (_ : P.parserMap S.outLiteral (C.cExpect C.cString) input) 122 (_ : lazyBool 123 (_ : P.parserMap S.outLiteral (C.cExpect C.cNumber) input) 124 (_ : lazyBool 125 (_ : P.parserThen (C.cExpect C.cLeft) (P.parserOr 126 (P.parserMap (_ : S.outLiteral t) (C.cExpect C.cRight)) 127 (bsPairOutput (other : stream : self stream other reference) bindings C.cRight C.cBar)) input) 128 (_ : lazyBool 129 (_ : P.parserThen (C.cExpect C.cOpen) (bsPairOutput (other : stream : self stream other reference) bindings C.cClose C.cComma) input) 130 (_ : P.parserReplyFail (C.cExpected "template" (C.cKind token) (C.cStart token)) input false false) 131 (equal? (C.cKind token) C.cOpen)) 132 (equal? (C.cKind token) C.cLeft)) 133 (equal? (C.cKind token) C.cNumber)) 134 (equal? (C.cKind token) C.cString)) 135 (equal? (C.cKind token) C.cName)) 136 input 137 -- A qualified name is never a capture or an implicit worker conversion. 138 -- The reference callback is a frontend parser; it may resolve into a literal 139 -- tree or record a dedicated source node for later local dependency staging. 140 bsOutputQualified self bindings reference name location input = (lazyList 141 (_ : bsOutputName self bindings name input) 142 (token rest : lazyBool 143 (_ : P.parserThen (C.cExpect C.cDot) 144 (P.parserBind (C.cExpect C.cName) (member : 145 reference (append name (pair 46 member)) location)) input) 146 (_ : bsOutputName self bindings name input) 147 (equal? (C.cKind token) C.cDot)) input) 148 bsRejectReference name location = (P.parserFailure 149 (P.parserDiagnostic 22 "module tree binding" name location t)) 150 bsOutputUsing bindings reference = input : y bsOutputUsing_ input bindings reference 151 bsOutput bindings = bsOutputUsing bindings bsRejectReference 152 153 -- Sidecar locations refer to the starting token of each rule and output. 154 -- The existing source API still returns only authored IR; callers needing 155 -- attribution can request the aligned sidecar without annotating every tree. 156 bsPosition = P.parserMap C.cStart P.parserPeek 157 bsRuleLocatedUsing reference = P.parserBind bsPosition (ruleStart : 158 P.parserBind (bsPattern t) (input : 159 P.parserThen (C.cExpect C.cAt) 160 (P.parserBind (bsPattern (snd input)) (state : 161 P.parserThen (C.cExpect C.cArrow) 162 (P.parserBind bsPosition (outputStart : 163 P.parserMap (output : pair 164 (S.makeRule (fst input) (fst state) output) 165 (pair ruleStart outputStart)) 166 (bsOutputUsing (snd state) reference))))))) 167 bsRuleLocated = bsRuleLocatedUsing bsRejectReference 168 bsRule = P.parserMap fst bsRuleLocated 169 -- Canonical single-consumer library files can carry their native export 170 -- declaration. Legacy probes accept exactly one matching !export NAME; 171 -- imports, wildcard/multiple exports and module bodies use the unit frontend. 172 -- Parsing the annotation as tokens retains original rule/output positions. 173 bsExport = (P.parserBind bsPosition (location : 174 P.parserThen (C.cExpect C.cBang) (P.parserThen (C.cWord "export") 175 (P.parserMap (name : just (pair name location)) (C.cExpect C.cName))))) 176 bsProgramBodyLocated declared = (P.parserThen (C.cWord "consumer") 177 (P.parserBind (C.cExpect C.cName) (name : 178 P.parserThen (lazyMaybe (_ : P.parserPure t) 179 (annotation : lazyBool (_ : P.parserPure t) 180 (_ : P.parserFailure (P.parserDiagnostic 22 "matching single export" 181 (fst annotation) (snd annotation) t)) 182 (equal? name (fst annotation))) declared) 183 (P.parserBind (P.parserSome bsRuleLocated) (rows : 184 P.parserMap (_ : pair (pair name (S.makeConsumer t (map fst rows))) 185 (map snd rows)) P.parserEof))))) 186 bsProgramLocated = (P.parserBind 187 (P.parserOr bsExport (P.parserPure nothing)) bsProgramBodyLocated) 188 bsProgram = P.parserMap fst bsProgramLocated 189 compileBaseSourceLocated source = (P.parserMatchReply 190 (diagnostic rest consumed committed : err diagnostic t) 191 (value rest consumed committed : ok value t) 192 (P.parserWithLexer C.lexConsumer bsProgramLocated source)) 193 compileBaseSource source = (bindResult (compileBaseSourceLocated source) 194 (value _ : ok (fst value) t)) 195 -- Locate a structured validation/backend diagnostic using its zero-based rule 196 -- index and reversed pattern/output path. Return t if no rule is available. 197 bsRuleLocation_ self rows index = (lazyList (_ : nothing) 198 (row rest : lazyBool (_ : just row) 199 (_ : self rest (pred_ index)) (isZero_? index)) rows) 200 bsRuleLocation rows index = y bsRuleLocation_ rows index 201 bsPathOutput_ self path = (lazyList (_ : false) 202 (part rest : lazyBool (_ : true) (_ : self rest) 203 (equal? part "output")) path) 204 bsPathOutput path = y bsPathOutput_ path 205 bsDiagnosticLocation diagnostic locations = (lazyMaybe (_ : t) 206 (row : lazyBool (_ : snd row) (_ : fst row) 207 (bsPathOutput (fst (snd (snd diagnostic))))) 208 (bsRuleLocation locations (fst (snd diagnostic))))