03da9f3b12997eea5c158dd08c31499531a4c9fbfc3fadad1f8e482f7cd7fb29.tri (16703B)
1 !import prelude * 2 !import parser * 3 !import source_lexer * 4 !import source_ast * 5 !import source_pattern * 6 !import source_core * 7 !export * 8 9 -- Located surface patterns have one AST kind and explicit lowerer tags 0..7. 10 -- Do not derive tags by arithmetic on an abstract AST kind at export time. 11 -- Pin payloads are located names, not resolved core yet. 12 sourceEquationPattern tag payload start end = sourceAstNode sourceAstPatternKind (pair tag payload) start end 13 sourceEquationTag pattern = fst (sourceAstPayload pattern) 14 sourceEquationPayload pattern = snd (sourceAstPayload pattern) 15 sourceEquationLocation pattern = sourceAstStart pattern 16 sourceEquationExpect kind input{[token | rest]} = (lazyBool 17 (_ : parserReplyOk token rest true false) 18 (_ : parserReplyFail (parserDiagnostic 2 kind (sourceTokenKind token) 19 (sourceTokenStart token) t) input false false) 20 (equal? (sourceTokenKind token) kind)) 21 sourceEquationExpect kind input = 22 parserReplyFail (parserDiagnostic 2 kind t t t) input false false 23 sourceEquationSkip = parserMap (_ : t) (parserMany (sourceEquationExpect sourceTokenNewline)) 24 sourceEquationError label input{[token | _]} = 25 parserReplyFail (parserDiagnostic 48 label (sourceTokenKind token) 26 (sourceTokenStart token) t) input false false 27 sourceEquationError label input = 28 parserReplyFail (parserDiagnostic 48 label t t t) input false false 29 sourceEquationFromToken tag token = (sourceEquationPattern tag (sourceTokenPayload token) 30 (sourceTokenStart token) (sourceTokenEnd token)) 31 sourceEquationWildcard token = sourceEquationPattern 0 t (sourceTokenStart token) (sourceTokenEnd token) 32 sourceEquationLeaf token = sourceEquationPattern 1 t (sourceTokenStart token) (sourceTokenEnd token) 33 sourceEquationLiteral token = sourceEquationFromToken 5 token 34 sourceEquationPair left right = (sourceEquationPattern 3 (pair left right) 35 (sourceAstStart left) (sourceAstEnd right)) 36 sourceEquationNil token = sourceEquationLeaf token 37 sourceEquationList_ self [head | rest] nil = 38 sourceEquationPair head (self rest nil) 39 sourceEquationList_ self elements nil = nil 40 sourceEquationList elements nil = y sourceEquationList_ elements nil 41 42 sourceEquationName parse input = (parserBind (sourceEquationExpect sourceTokenName) (name : 43 lazyBool (_ : parserPure (sourceEquationWildcard name)) 44 (_ : parserBind (parserOptional (sourceEquationExpect sourceTokenLeftBrace)) (brace : 45 lazyMaybe (_ : parserPure (sourceEquationFromToken 4 name)) 46 (open : parserThen sourceEquationSkip 47 (parserBind (sourceEquationInside parse) (child : 48 parserThen sourceEquationSkip 49 (parserMap (close : sourceEquationPattern 6 50 (pair (sourceTokenPayload name) child) 51 (sourceTokenStart name) (sourceTokenEnd close)) 52 (sourceEquationExpect sourceTokenRightBrace))))) brace)) 53 (equal? (sourceTokenPayload name) "_")) input) 54 sourceEquationPin input = (parserBind (sourceEquationExpect sourceTokenPin) (pin : 55 parserMap (name : sourceEquationPattern 7 (sourceAstName name) 56 (sourceTokenStart pin) (sourceTokenEnd name)) 57 (sourceEquationExpect sourceTokenName)) input) 58 59 -- Braces and parentheses contain one complete pattern. A leading `t` may 60 -- have zero, one or two child atoms here, never in an ungrouped argument. 61 sourceEquationConstructor parse input = (parserBind (sourceEquationExpect sourceTokenT) (leaf : 62 parserThen sourceEquationSkip 63 (parserBind (parserMany (parserBefore parse sourceEquationSkip)) (children : 64 lazyList (_ : parserPure (sourceEquationLeaf leaf)) 65 (first rest : lazyList 66 (_ : parserPure (sourceEquationPattern 2 first 67 (sourceTokenStart leaf) (sourceAstEnd first))) 68 (second tail : lazyList 69 (_ : parserPure (sourceEquationPattern 3 (pair first second) 70 (sourceTokenStart leaf) (sourceAstEnd second))) 71 (extra unused : tokens : sourceEquationError "at most two tree children" tokens) 72 tail) rest) children))) input) 73 sourceEquationInside parse input = (parserBind 74 (parserBefore (parserOr (sourceEquationConstructor parse) parse) sourceEquationSkip) (left : 75 parserBind (parserOptional (sourceEquationExpect sourceTokenComma)) (comma : 76 lazyMaybe (_ : parserPure left) 77 (_ : parserThen sourceEquationSkip 78 (parserMap (right : sourceEquationPair left right) parse)) comma)) input) 79 sourceEquationGroup parse input = (parserBind (sourceEquationExpect sourceTokenOpen) (open : 80 parserThen sourceEquationSkip 81 (parserBind (sourceEquationInside parse) (child : 82 parserThen sourceEquationSkip 83 (parserMap (close : sourceAstNode (sourceAstKind child) (sourceAstPayload child) 84 (sourceTokenStart open) (sourceTokenEnd close)) 85 (sourceEquationExpect sourceTokenClose))))) input) 86 sourceEquationListPattern parse input = (parserBind (sourceEquationExpect sourceTokenLeftBracket) (open : 87 parserThen sourceEquationSkip 88 (parserBind (parserMany (parserBefore parse sourceEquationSkip)) (elements : 89 parserBind (parserOptional (parserThen (sourceEquationExpect sourceTokenBar) 90 (parserThen sourceEquationSkip (parserBefore parse sourceEquationSkip)))) (tail : 91 parserBind (sourceEquationExpect sourceTokenRightBracket) (close : 92 lazyMaybe 93 (_ : parserPure (sourceAstNode 94 (sourceAstKind (sourceEquationList elements (sourceEquationNil close))) 95 (sourceAstPayload (sourceEquationList elements (sourceEquationNil close))) 96 (sourceTokenStart open) (sourceTokenEnd close))) 97 (rest : lazyList 98 (_ : tokens : sourceEquationError "nonempty list prefix" tokens) 99 (head unused : parserPure (sourceAstNode 100 (sourceAstKind (sourceEquationList elements rest)) 101 (sourceAstPayload (sourceEquationList elements rest)) 102 (sourceTokenStart open) (sourceTokenEnd close))) elements) 103 tail))))) input) 104 sourceEquationParse_ self input = (parserOr 105 (sourceEquationName self) 106 (parserOr (parserMap sourceEquationLeaf (sourceEquationExpect sourceTokenT)) 107 (parserOr (parserMap sourceEquationLiteral (sourceEquationExpect sourceTokenNumber)) 108 (parserOr (parserMap sourceEquationLiteral (sourceEquationExpect sourceTokenString)) 109 (parserOr sourceEquationPin 110 (parserOr (sourceEquationGroup self) 111 (parserOr (sourceEquationListPattern self) 112 (sourceEquationError "pattern"))))))) input) 113 sourceEquationParse input = y sourceEquationParse_ input 114 115 -- Binding heads are shared by program and local parsers. Zero-argument 116 -- values remain ordinary expressions; positive-arity bindings retain equations. 117 sourceEquationBinding valueParser input = (parserBind 118 (sourceEquationExpect sourceTokenName) (name : 119 parserBind (parserMany sourceEquationParse) (patterns : 120 parserThen (sourceEquationExpect sourceTokenAssign) 121 (parserMap (body : pair name (lazyList (_ : body) 122 (_ rest : sourceAstEquations [(pair patterns body)] 123 (sourceTokenStart name) (sourceAstEnd body)) patterns)) valueParser))) input) 124 125 -- Merge only contiguous positive-arity plain equations. Values/annotations 126 -- stay ordinary nodes and cannot silently become multi-equation definitions. 127 sourceEquationMerge prior next = (pair (fst prior) 128 (sourceAstEquations (pair (fst (sourceAstPayload (snd next))) (sourceAstPayload (snd prior))) 129 (sourceAstStart (snd prior)) (sourceAstEnd (snd next)))) 130 -- A singleton, unique, all-name head needs no matcher. Keep this cheap path 131 -- for ordinary compiler/library functions and their original binder spans. 132 sourceEquationPlain_ self patterns seen = (lazyList (_ : true) 133 (pattern rest : lazyBool 134 (_ : lazyBool (_ : false) 135 (_ : self rest (pair (sourceEquationPayload pattern) seen)) 136 (sourceEquationHasName seen (sourceEquationPayload pattern))) 137 (_ : false) (equal? (sourceEquationTag pattern) 4)) patterns) 138 sourceEquationPlain? patterns = y sourceEquationPlain_ patterns t 139 sourceEquationLambda body pattern = (sourceAstLambda 140 (sourceToken sourceTokenName (sourceEquationPayload pattern) 141 (sourceAstStart pattern) (sourceAstEnd pattern)) body) 142 sourceEquationFinishValue node equations = (lazyList (_ : node) 143 (equation rest : lazyBool 144 (_ : foldr sourceEquationLambda (snd equation) (fst equation)) 145 (_ : sourceAstEquations equations (sourceAstStart node) (sourceAstEnd node)) 146 (and? (emptyList? rest) (sourceEquationPlain? (fst equation)))) equations) 147 sourceEquationFinish binding = (lazyBool 148 (_ : pair (fst binding) (sourceEquationFinishValue (snd binding) 149 (reverse (sourceAstPayload (snd binding))))) 150 (_ : binding) (equal? (sourceAstKind (snd binding)) sourceAstEquationsKind)) 151 sourceEquationGroups_ self bindings reversed = (lazyList 152 (_ : ok (map sourceEquationFinish (reverse reversed)) t) 153 (binding rest : lazyList 154 (_ : self rest [binding]) 155 (prior tail : lazyBool 156 (_ : lazyBool 157 (_ : self rest (pair (sourceEquationMerge prior binding) tail)) 158 (_ : self rest (pair binding reversed)) 159 (and? (equal? (sourceAstKind (snd prior)) sourceAstEquationsKind) 160 (equal? (sourceAstKind (snd binding)) sourceAstEquationsKind))) 161 (_ : self rest (pair binding reversed)) 162 (equal? (sourceTokenPayload (fst binding)) (sourceTokenPayload (fst prior)))) reversed) 163 bindings) 164 sourceEquationGroups bindings = y sourceEquationGroups_ bindings t 165 166 -- Traversals consume surface pattern syntax before inspecting control state. 167 sourceEquationCaptures_ self pattern = (let tag = sourceEquationTag pattern in 168 let payload = sourceEquationPayload pattern in 169 lazyBool (_ : [payload]) 170 (_ : lazyBool (_ : pair (fst payload) (self (snd payload))) 171 (_ : lazyBool (_ : self payload) 172 (_ : lazyBool (_ : append (self (fst payload)) (self (snd payload))) 173 (_ : t) (equal? tag 3)) (equal? tag 2)) (equal? tag 6)) (equal? tag 4)) 174 sourceEquationCaptures pattern = y sourceEquationCaptures_ pattern 175 sourceEquationPins_ self pattern = (let tag = sourceEquationTag pattern in 176 let payload = sourceEquationPayload pattern in 177 lazyBool (_ : [payload]) 178 (_ : lazyBool (_ : self (snd payload)) 179 (_ : lazyBool (_ : self payload) 180 (_ : lazyBool (_ : append (self (fst payload)) (self (snd payload))) 181 (_ : t) (equal? tag 3)) (equal? tag 2)) (equal? tag 6)) (equal? tag 7)) 182 sourceEquationPins pattern = y sourceEquationPins_ pattern 183 sourceEquationCollect_ self patterns collect = (lazyList (_ : t) 184 (pattern rest : append (collect pattern) (self rest collect)) patterns) 185 sourceEquationCollect patterns collect = y sourceEquationCollect_ patterns collect 186 187 -- Look ahead across this head, allowing newlines inside delimiters. Nested 188 -- let/do assignments belong to expressions, not definitions. The delimiter 189 -- stack comes from consumed tokens, never an arithmetic depth counter. 190 sourceEquationHeadStop? kind = (or? (equal? kind sourceTokenLet) 191 (or? (equal? kind sourceTokenIn) (or? (equal? kind sourceTokenWhere) 192 (or? (equal? kind sourceTokenDo) (or? (equal? kind sourceTokenBindArrow) 193 (or? (equal? kind sourceTokenPipeBackward) (equal? kind sourceTokenPipeForward))))))) 194 sourceEquationOpening kind = (lazyBool (_ : just sourceTokenClose) 195 (_ : lazyBool (_ : just sourceTokenRightBracket) 196 (_ : lazyBool (_ : just sourceTokenRightBrace) (_ : nothing) 197 (equal? kind sourceTokenLeftBrace)) (equal? kind sourceTokenLeftBracket)) 198 (equal? kind sourceTokenOpen)) 199 sourceEquationAssignLine_ self input delimiters = (lazyList (_ : false) 200 (token rest : let kind = sourceTokenKind token in (lazyBool (_ : true) 201 (_ : lazyBool (_ : false) 202 (_ : lazyBool 203 (_ : lazyBool (_ : false) (_ : self rest delimiters) (emptyList? delimiters)) 204 (_ : lazyMaybe 205 (_ : lazyList (_ : self rest delimiters) 206 (close tail : lazyBool (_ : self rest tail) 207 (_ : self rest delimiters) (equal? kind close)) delimiters) 208 (close : self rest (pair close delimiters)) (sourceEquationOpening kind)) 209 (equal? kind sourceTokenNewline)) (sourceEquationHeadStop? kind)) 210 (equal? kind sourceTokenAssign))) input) 211 sourceEquationAssignLine? input = y sourceEquationAssignLine_ input t 212 sourceEquationBindingHead? input = (lazyList (_ : false) 213 (token rest : and? (equal? (sourceTokenKind token) sourceTokenName) 214 (sourceEquationAssignLine? rest)) input) 215 sourceEquationHasName_ self names name = (lazyList (_ : false) 216 (head rest : lazyBool (_ : true) (_ : self rest name) (equal? head name)) names) 217 sourceEquationHasName names name = y sourceEquationHasName_ names name 218 sourceEquationUnique_ self bindings seen = (lazyList (_ : ok t t) 219 (binding rest : let name = sourceTokenPayload (fst binding) in (lazyBool 220 (_ : err (parserDiagnostic 30 name name (sourceTokenStart (fst binding)) t) binding) 221 (_ : self rest (pair name seen)) (sourceEquationHasName seen name))) bindings) 222 sourceEquationUnique bindings = y sourceEquationUnique_ bindings t 223 224 -- Syntax-only validation happens before dependency/name checking. In 225 -- particular a confusing capture/pin collision must not become a missing-name 226 -- or accidental dependency-cycle error. Pins in this skeleton are never run. 227 sourceEquationSkeleton_ self pattern = (let tag = sourceEquationTag pattern in 228 let payload = sourceEquationPayload pattern in 229 sourcePatternNode tag 230 (lazyBool (_ : self payload) 231 (_ : lazyBool (_ : pair (self (fst payload)) (self (snd payload))) 232 (_ : lazyBool (_ : pair (fst payload) (self (snd payload))) 233 (_ : lazyBool (_ : spLit t) (_ : payload) (equal? tag 7)) 234 (equal? tag 6)) (equal? tag 3)) (equal? tag 2)) 235 (sourceAstStart pattern)) 236 sourceEquationSkeleton pattern = y sourceEquationSkeleton_ pattern 237 sourceEquationSkeletonArm equation = (sourceEquation 238 (map sourceEquationSkeleton (fst equation)) 239 (sourceCoreLeaf (sourceAstStart (snd equation)) (sourceAstEnd (snd equation)))) 240 sourceEquationCheckPins_ self pins captures = (lazyList (_ : ok t t) 241 (pin rest : lazyBool 242 (_ : err (parserDiagnostic 48 "pin outside equation captures" 243 (sourceAstPayload pin) (sourceAstStart pin) t) pin) 244 (_ : self rest captures) 245 (sourceEquationHasName captures (sourceAstPayload pin))) pins) 246 sourceEquationCheckPins patterns = (y sourceEquationCheckPins_ 247 (sourceEquationCollect patterns sourceEquationPins) 248 (sourceEquationCollect patterns sourceEquationCaptures)) 249 sourceEquationCheckArms_ self equations = (lazyList (_ : ok t t) 250 (equation rest : lazyResult (diagnostic remainder : err diagnostic remainder) 251 (_ unused : self rest) (sourceEquationCheckPins (fst equation))) equations) 252 sourceEquationValidateArms equations = (lazyList 253 (_ : err (parserDiagnostic 48 "nonempty equations" t t t) t) 254 (first rest : spValidateEquations (map sourceEquationSkeletonArm equations) 255 (length (fst first))) equations) 256 sourceEquationCheckGroup node = (lazyResult 257 (diagnostic remainder : err diagnostic remainder) 258 (_ unused : y sourceEquationCheckArms_ (sourceAstPayload node)) 259 (sourceEquationValidateArms (sourceAstPayload node))) 260 sourceEquationChildren node = (let kind = sourceAstKind node in 261 let payload = sourceAstPayload node in 262 lazyBool (_ : [ (fst payload) (snd payload) ]) 263 (_ : lazyBool (_ : [(snd payload)]) 264 (_ : lazyBool (_ : [payload]) 265 (_ : lazyBool (_ : payload) 266 (_ : lazyBool (_ : [ (sourceAstLetValue node) (sourceAstLetBody node) ]) 267 (_ : lazyBool (_ : [ (sourceAstPipeLeft node) (sourceAstPipeRight node) ]) 268 (_ : lazyBool (_ : [(sourceAstDoLower node)]) 269 (_ : lazyBool (_ : map snd payload) (_ : t) 270 (equal? kind sourceAstEquationsKind)) 271 (equal? kind sourceAstDoKind)) (equal? kind sourceAstPipeKind)) 272 (equal? kind sourceAstLetKind)) (equal? kind sourceAstListKind)) 273 (equal? kind sourceAstGroupKind)) (equal? kind sourceAstLambdaKind)) 274 (equal? kind sourceAstApplyKind)) 275 sourceEquationVisit_ self nodes visit = (lazyList (_ : ok t t) 276 (node rest : lazyResult (diagnostic remainder : err diagnostic remainder) 277 (_ unused : self rest visit) (visit node)) nodes) 278 sourceEquationVisit nodes visit = y sourceEquationVisit_ nodes visit 279 sourceEquationValidate_ self node = (lazyResult 280 (diagnostic remainder : err diagnostic remainder) 281 (_ unused : sourceEquationVisit (sourceEquationChildren node) self) 282 (lazyBool (_ : sourceEquationCheckGroup node) (_ : ok t t) 283 (equal? (sourceAstKind node) sourceAstEquationsKind))) 284 sourceEquationValidate node = y sourceEquationValidate_ node 285