unit-source.tri (6095B)
1 !import prelude * 2 !import parser as P 3 !import consumers_source as C 4 !import consumers_base_source as B 5 !import consumers_structural as S 6 !export * 7 -- Multi-consumer frontend. Pending qualified references are SOURCE nodes, 8 -- not authored IR; resolve them before validation or either execution path. 9 -- Entry points: parseScpUnit (requires definitions), parseScpModuleBody (allows 10 -- header-only modules). us* constructors/traversals are frontend internals. 11 12 usReferenceTag = "scp-source.reference.v1" 13 usReference name location = P.parserPure (pair usReferenceTag (pair name location)) 14 usDeclaration? tokens = (lazyList (_ : false) 15 (token rest : and? (and? (equal? (C.cKind token) C.cName) 16 (equal? (C.cPayload token) "consumer")) 17 (lazyList (_ : false) (name tail : equal? (C.cKind name) C.cName) rest)) tokens) 18 usRule input = (lazyBool 19 (_ : P.parserReplyFail (C.cExpected "rule" "consumer" t) input false false) 20 (_ : B.bsRuleLocatedUsing usReference input) 21 (usDeclaration? input)) 22 -- Definition = (name, (consumer/source tree, (declaration location, rule locations))). 23 usDefinition = (P.parserBind B.bsPosition (location : 24 P.parserThen (C.cWord "consumer") 25 (P.parserBind (C.cExpect C.cName) (name : 26 P.parserMap (rows : pair name (pair 27 (S.makeConsumer t (map fst rows)) (pair location (map snd rows)))) 28 (P.parserSome usRule))))) 29 usDefinitions_ self input seen = (P.parserMatchReply 30 (problem rest consumed committed : P.parserReplyFail problem rest consumed committed) 31 (definition rest consumed committed : lazyBool 32 (_ : P.parserReplyFail 33 (P.parserDiagnostic 21 "fresh consumer name" (fst definition) 34 (fst (snd (snd definition))) t) rest true false) 35 (_ : P.parserMatchReply 36 (problem tail consumed2 committed2 : P.parserReplyFail problem tail true committed2) 37 (definitions tail consumed2 committed2 : P.parserReplyOk 38 (pair definition definitions) tail true committed2) 39 (lazyList (_ : P.parserReplyOk t rest false false) 40 (_ _ : self rest (pair (pair (fst definition) t) seen)) rest)) 41 (C.cNameUsed seen (fst definition))) 42 (usDefinition input)) 43 usDefinitions input = y usDefinitions_ input t 44 usModuleDefinitions input = (lazyList 45 (_ : P.parserReplyOk t input false false) 46 (_ _ : usDefinitions input) input) 47 parseScpModuleBody source = (P.parserMatchReply 48 (problem rest consumed committed : err problem t) 49 (definitions rest consumed committed : ok definitions t) 50 (P.parserWithLexer C.lexScpUnit 51 (P.parserBefore usModuleDefinitions P.parserEof) source)) 52 parseScpUnit source = (P.parserMatchReply 53 (problem rest consumed committed : err problem t) 54 (definitions rest consumed committed : ok definitions t) 55 (P.parserWithLexer C.lexScpUnit 56 (P.parserBefore usDefinitions P.parserEof) source)) 57 58 usTwo self tag payload = (matchPair (left right : 59 bindResult (self left) (a _ : bindResult (self right) 60 (b _ : ok (pair tag (pair a b)) t))) payload) 61 usThree self tag payload = (matchPair (first rest : 62 matchPair (second third : bindResult (self first) (a _ : 63 bindResult (self second) (b _ : bindResult (self third) 64 (c _ : ok (pair tag (pair a (pair b c))) t)))) rest) payload) 65 usCall self payload = (matchPair (target rest : 66 matchPair (argument continuation : matchPair (slot receiver : 67 bindResult (self target) (worker _ : 68 bindResult (self argument) (input _ : 69 bindResult (self receiver) (body _ : 70 ok (S.outCall worker input slot body) t)))) continuation) rest) payload) 71 usArms_ self arms output = (lazyList (_ : ok t t) 72 (arm rest : bindResult (output (snd arm)) (body _ : 73 bindResult (self rest output) (tail _ : 74 ok (pair (pair (fst arm) body) tail) t))) arms) 75 usArms arms output = y usArms_ arms output 76 usOutput_ self output reference = (matchPair (tag payload : 77 lazyBool (_ : reference (fst payload) (snd payload)) 78 (_ : lazyBool (_ : ok output t) 79 (_ : lazyBool (_ : ok output t) 80 (_ : lazyBool (_ : usTwo (child : self child reference) tag payload) 81 (_ : lazyBool (_ : usTwo (child : self child reference) tag payload) 82 (_ : lazyBool (_ : usCall (child : self child reference) payload) 83 (_ : lazyBool (_ : bindResult (self payload reference) 84 (child _ : ok (S.outStem child) t)) 85 (_ : lazyBool (_ : usThree (child : self child reference) tag payload) 86 (_ : lazyBool (_ : usTwo (child : self child reference) tag payload) 87 (_ : lazyBool (_ : matchPair (source arms : 88 bindResult (self source reference) (scrutinee _ : 89 bindResult (usArms arms (child : self child reference)) 90 (resolved _ : ok (S.outMatch scrutinee resolved) t))) payload) 91 (_ : err "unknown source output node" t) (equal? tag 9)) 92 (equal? tag 8)) (equal? tag 6)) (equal? tag 5)) 93 (equal? tag 4)) (equal? tag 3)) (equal? tag 2)) 94 (equal? tag 1)) (equal? tag 0)) 95 (equal? tag usReferenceTag)) output) 96 usOutput output reference = y usOutput_ output reference 97 usRules_ self rules reference = (lazyList (_ : ok t t) 98 (rule rest : bindResult (usOutput (snd (snd rule)) reference) (output _ : 99 bindResult (self rest reference) (tail _ : ok 100 (pair (S.makeRule (fst rule) (fst (snd rule)) output) tail) t))) rules) 101 usRules rules reference = y usRules_ rules reference 102 -- available includes selected imported values and already compiled local code. 103 -- declared lists all qualified names in this build; missing declared code is 104 -- a pending dependency, distinct from an unknown reference. Literals stay opaque. 105 usLookup available declared name location = (lazyMaybe 106 (_ : err (P.parserDiagnostic 107 (lazyBool (_ : 23) (_ : 22) (C.cNameUsed declared name)) 108 "available module tree binding" name location t) t) 109 (slot : ok (S.outLiteral slot) t) 110 (C.cSlot available name)) 111 usResolveDefinition definition available declared = (bindResult 112 (usRules (snd (fst (snd definition))) 113 (name location : usLookup available declared name location)) 114 (rules _ : ok (pair (fst definition) 115 (pair (S.makeConsumer (fst (fst (snd definition))) rules) 116 (snd (snd definition)))) t))