db3119de70e07b94a49c94a6575b2bb9618f71702b8e954e8635d957bc93b7df.tri (22396B)
1 !import prelude * 2 !import parser * 3 !import source_lexer * 4 !import source_ast * 5 !import source_equations * 6 !export * 7 8 -- Small, single-expression gate grammar. Its recursive expression parser is 9 -- one fixed point behind a wrapper; atom/application/lambda helpers receive 10 -- the recursive parser as an argument rather than forming top-level cycles. 11 sourceGateExpected kind found location = 12 parserDiagnostic 2 kind found location t 13 14 sourceGateExpect kind input = 15 lazyList 16 (_ : parserReplyFail (sourceGateExpected kind t t) input false false) 17 (token rest : 18 lazyBool 19 (_ : parserReplyOk token rest true false) 20 (_ : parserReplyFail 21 (sourceGateExpected kind (sourceTokenKind token) 22 (sourceTokenStart token)) input false false) 23 (equal? (sourceTokenKind token) kind)) 24 input 25 26 sourceGateEof input = 27 lazyList 28 (_ : parserReplyOk t input false false) 29 (token rest : parserReplyFail 30 (sourceGateExpected t (sourceTokenKind token) 31 (sourceTokenStart token)) input false false) 32 input 33 34 -- A lambda head is one or more name tokens followed by a same-line colon. 35 -- Stop scanning on the first non-name; do not mistake an ordinary `f x` 36 -- application for a multi-binder head when no colon follows. 37 sourceGateLambdaHead_ self input seen = 38 lazyList 39 (_ : false) 40 (token rest : 41 lazyBool 42 (_ : self rest true) 43 (_ : and? seen (equal? (sourceTokenKind token) sourceTokenColon)) 44 (equal? (sourceTokenKind token) sourceTokenName)) 45 input 46 47 sourceGateLambdaHead? = (input : y sourceGateLambdaHead_ input false) 48 49 sourceGateParseLambda expression input = 50 parserBind (parserSome (sourceGateExpect sourceTokenName)) (names : 51 parserThen (sourceGateExpect sourceTokenColon) 52 (parserThen sourceGateSkipNestedNewlines 53 (parserMap (body : foldr 54 (value name : sourceAstLambda name value) body names) 55 expression))) input 56 57 sourceGateParseGroup expression input = 58 parserBind (sourceGateExpect sourceTokenOpen) (open : 59 parserThen sourceGateSkipNestedNewlines 60 (parserBind expression (body : 61 parserThen sourceGateSkipNestedNewlines 62 (parserMap (close : sourceAstGroup open body close) 63 (sourceGateExpect sourceTokenClose))))) input 64 65 -- Shared binding head: retain patterns until contiguous equations have 66 -- coalesced. Only unique all-name singleton heads take the lambda fast path. 67 sourceGateParseBindingWith valueParser input = sourceEquationBinding valueParser input 68 69 sourceGateParseBinding expression = sourceGateParseBindingWith expression 70 71 -- Shared layout transition after `=`, `in`, or another binding boundary. 72 -- Inline values use the enclosing expression context. After newlines, the 73 -- next located token selects the new indentation context without rewriting 74 -- source text or exposing recursion driven by a known indentation counter. 75 sourceGateParseLayoutFirst expression indentedExpression label input = 76 lazyList 77 (_ : parserReplyFail (parserDiagnostic 40 label t t t) 78 input false false) 79 (token rest : 80 lazyBool 81 (_ : expression input) 82 (_ : indentedExpression 83 (sourcePositionColumn (sourceTokenStart token)) input) 84 (equal? (sourcePositionColumn (sourceTokenStart token)) 1)) 85 input 86 87 sourceGateParseLayoutValue expression indentedExpression label input = 88 lazyList 89 (_ : expression input) 90 (token rest : 91 lazyBool 92 (_ : parserThen sourceGateSkipNestedNewlines 93 (sourceGateParseLayoutFirst expression indentedExpression label) 94 input) 95 (_ : expression input) 96 (equal? (sourceTokenKind token) sourceTokenNewline)) 97 input 98 99 -- Local groups share the program head grammar, but are deliberately not 100 -- dependency-sorted: nested nonrecursive lets expose only earlier groups. 101 sourceGateLocalValue indentedExpression column input = 102 sourceGateParseLayoutValue (indentedExpression column) indentedExpression 103 "local binding value" input 104 sourceGateLocalNext? input column = (lazyList (_ : false) 105 (token rest : lazyBool 106 (_ : sourceGateLocalAfterNewlines? rest column) 107 (_ : false) (equal? (sourceTokenKind token) sourceTokenNewline)) input) 108 sourceGateLocalAfterNewlines_ self input column = (lazyList (_ : false) 109 (token rest : lazyBool (_ : self rest column) 110 (_ : and? (equal? (sourcePositionColumn (sourceTokenStart token)) column) 111 (sourceEquationBindingHead? input)) 112 (equal? (sourceTokenKind token) sourceTokenNewline)) input) 113 sourceGateLocalAfterNewlines? input column = y sourceGateLocalAfterNewlines_ input column 114 sourceGateLocalNext indentedExpression column input = (lazyBool 115 (_ : parserThen sourceGateSkipNestedNewlines 116 (sourceEquationBinding (sourceGateLocalValue indentedExpression column)) input) 117 (_ : parserReplyFail (sourceGateExpected "local equation" t t) input false false) 118 (sourceGateLocalNext? input column)) 119 sourceGateLocalGroupsReply bindings input = (lazyResult 120 (diagnostic remainder : parserReplyFail diagnostic input false false) 121 (groups unused : lazyResult 122 (diagnostic remainder : parserReplyFail diagnostic input false false) 123 (_ unused : parserReplyOk groups input false false) 124 (sourceEquationUnique groups)) (sourceEquationGroups bindings)) 125 sourceGateLocalBindings indentedExpression input = (lazyList 126 (_ : sourceGateAtomError input) 127 (token rest : parserBind 128 (sourceEquationBinding (sourceGateLocalValue indentedExpression 129 (sourcePositionColumn (sourceTokenStart token)))) 130 (first : parserBind (parserMany (sourceGateLocalNext indentedExpression 131 (sourcePositionColumn (sourceTokenStart token)))) 132 (remaining : sourceGateLocalGroupsReply (pair first remaining))) input) input) 133 sourceGateLocalBuild bindings body start end = (foldr 134 (rest binding : sourceAstLocal (fst binding) (snd binding) rest start end) 135 body bindings) 136 sourceGateLocalIndented indentedExpression parentColumn input = (lazyList 137 (_ : parserReplyFail (parserDiagnostic 40 "indented local block" t t t) input false false) 138 (token rest : lazyBool 139 (_ : sourceGateLocalBindings indentedExpression input) 140 (_ : parserReplyFail (parserDiagnostic 40 "indented local block" 141 (sourceTokenKind token) (sourceTokenStart token) t) input false false) 142 (and? (not? (lte_? (sourcePositionColumn (sourceTokenStart token)) parentColumn)) 143 (not? (lte_? (sourcePositionColumn (sourceTokenStart token)) 1)))) input) 144 sourceGateLocalStart indentedExpression parentColumn input = (lazyList 145 (_ : sourceGateLocalBindings indentedExpression input) 146 (token rest : lazyBool 147 (_ : parserThen sourceGateSkipNestedNewlines 148 (sourceGateLocalIndented indentedExpression parentColumn) input) 149 (_ : sourceGateLocalBindings indentedExpression input) 150 (equal? (sourceTokenKind token) sourceTokenNewline)) input) 151 -- rec applies to exactly one contiguous function group. It is not a mutually 152 -- recursive block and never changes the scope of plain let/where bindings. 153 sourceGateLocalFinish ^false bindings body start end input = 154 parserReplyOk (sourceGateLocalBuild bindings body start end) input false false 155 sourceGateLocalFinish ^true [binding] body start end input = 156 parserReplyOk (sourceAstRecursive (fst binding) (snd binding) body start end) input false false 157 sourceGateLocalFinish _ _ _ start _ input = 158 parserReplyFail (parserDiagnostic 48 "one recursive local function" t start t) input false false 159 160 sourceGateRecursive = (parserMap (present : lazyMaybe (_ : false) (_ : true) present) 161 (parserOptional (sourceGateExpect sourceTokenRec))) 162 163 sourceGateParseLet expression indentedExpression parentColumn input = (parserBind 164 (sourceGateExpect sourceTokenLet) (keyword : parserBind sourceGateRecursive (recursive : 165 parserBind (sourceGateLocalStart indentedExpression parentColumn) (bindings : 166 parserThen sourceGateSkipNestedNewlines 167 (parserThen (sourceGateExpect sourceTokenIn) 168 (parserBind (sourceGateParseLayoutValue expression indentedExpression "local binding body") 169 (body : sourceGateLocalFinish recursive bindings body 170 (sourceTokenStart keyword) (sourceAstEnd body))))))) input) 171 sourceGateParseWhere expression indentedExpression body parentColumn input = (parserThen 172 (sourceGateExpect sourceTokenWhere) (parserBind sourceGateRecursive (recursive : 173 parserBind (sourceGateLocalStart indentedExpression parentColumn) (bindings : 174 sourceGateLocalFinish recursive bindings body (sourceAstStart body) 175 (sourceAstEnd (snd (foldl (_ binding : binding) (fst bindings) bindings)))))) input) 176 177 -- Case arms share equation patterns/validation. The branch column delimits 178 -- bodies, including nested cases and do blocks. A pattern has no function name. 179 sourceGateCaseArm expression column input = (parserBind sourceEquationParse (pattern : 180 parserThen (sourceGateExpect sourceTokenAssign) 181 (parserMap (body : pair [pattern] body) 182 (sourceGateParseLayoutValue (tokens : expression tokens (sourceGateLayoutIndented column)) 183 (indent tokens : expression tokens (sourceGateLayoutIndented indent)) "case arm body"))) input) 184 sourceGateCasePatternStarts? kind = (or? (sourceGateAtomStarts? kind) 185 (equal? kind sourceTokenPin)) 186 sourceGateCaseSameColumn_ self input column = (lazyList (_ : false) 187 (token rest : lazyBool (_ : self rest column) 188 (_ : and? (equal? (sourcePositionColumn (sourceTokenStart token)) column) 189 (sourceGateCasePatternStarts? (sourceTokenKind token))) 190 (equal? (sourceTokenKind token) sourceTokenNewline)) input) 191 sourceGateCaseNext expression column input = (lazyList 192 (_ : parserReplyFail (sourceGateExpected "case arm" t t) input false false) 193 (token rest : lazyBool 194 (_ : parserThen sourceGateSkipNestedNewlines (sourceGateCaseArm expression column) input) 195 (_ : parserReplyFail (sourceGateExpected "case arm" t t) input false false) 196 (and? (equal? (sourceTokenKind token) sourceTokenNewline) 197 (y sourceGateCaseSameColumn_ rest column))) input) 198 sourceGateCaseFirst expression keyword subject parentColumn input = (lazyList 199 (_ : parserReplyFail (parserDiagnostic 40 "indented case arms" t t t) input false false) 200 (token rest : let column = sourcePositionColumn (sourceTokenStart token) in 201 lazyBool 202 (_ : parserBind (sourceGateCaseArm expression column) (first : 203 parserMap (remaining : sourceAstCase subject (pair first remaining) 204 (sourceTokenStart keyword) (sourceAstEnd (snd (foldl (_ arm : arm) first remaining)))) 205 (parserMany (sourceGateCaseNext expression column))) input) 206 (_ : parserReplyFail (parserDiagnostic 40 "indented case arms" 207 (sourceTokenKind token) (sourceTokenStart token) t) input false false) 208 (and? (not? (lte_? column parentColumn)) (not? (lte_? column 1)))) input) 209 sourceGateParseCase expression mode input = (parserBind (sourceGateExpect sourceTokenCase) (keyword : 210 parserBind (tokens : expression tokens mode) (subject : 211 parserThen (sourceGateExpect sourceTokenOf) 212 (parserThen (sourceGateExpect sourceTokenNewline) 213 (parserThen sourceGateSkipNestedNewlines 214 (sourceGateCaseFirst expression keyword subject (snd mode)))))) input) 215 216 -- Newlines are meaningful between top-level expressions but are trivia 217 -- within a bracketed list. Each element is one atom: applications inside a 218 -- list need parentheses, as in the bootstrap grammar. 219 sourceGateSkipNestedNewlines = 220 parserMap (_ : t) (parserMany (sourceGateExpect sourceTokenNewline)) 221 222 sourceGateParseList atom input = 223 parserBind (sourceGateExpect sourceTokenLeftBracket) (open : 224 parserThen sourceGateSkipNestedNewlines 225 (parserBind 226 (parserMany 227 (parserBefore atom sourceGateSkipNestedNewlines)) 228 (elements : parserMap 229 (close : sourceAstList open elements close) 230 (sourceGateExpect sourceTokenRightBracket)))) input 231 232 sourceGateAtomError input = 233 lazyList 234 (_ : parserReplyFail (sourceGateExpected 7 t t) input false false) 235 (token rest : parserReplyFail 236 (sourceGateExpected 7 (sourceTokenKind token) 237 (sourceTokenStart token)) input false false) 238 input 239 240 -- A do block begins after an explicit operator atom and a newline. Its 241 -- statements start at one located column; deeper lines belong to the current 242 -- expression, while a new line at that column starts the next statement. 243 sourceGateDoBindHead? input = 244 lazyList 245 (_ : false) 246 (token rest : 247 lazyBool 248 (_ : lazyList 249 (_ : false) 250 (next tail : equal? (sourceTokenKind next) sourceTokenBindArrow) 251 rest) 252 (_ : false) 253 (equal? (sourceTokenKind token) sourceTokenName)) 254 input 255 256 sourceGateDoSameColumn_ self input column = 257 lazyList 258 (_ : false) 259 (token rest : 260 lazyBool 261 (_ : self rest column) 262 (_ : and? 263 (equal? (sourcePositionColumn (sourceTokenStart token)) column) 264 (sourceGateAtomStarts? (sourceTokenKind token))) 265 (equal? (sourceTokenKind token) sourceTokenNewline)) 266 input 267 268 sourceGateDoSameColumn? = (input column : 269 y sourceGateDoSameColumn_ input column) 270 271 sourceGateParseDoStatement expression indentedExpression column input = 272 lazyBool 273 (_ : parserBind (sourceGateExpect sourceTokenName) (name : 274 parserThen (sourceGateExpect sourceTokenBindArrow) 275 (parserMap (action : pair (just name) action) 276 (sourceGateParseLayoutValue 277 (tokens : expression tokens (sourceGateLayoutIndented column)) 278 indentedExpression "do binding action"))) input) 279 (_ : parserMap (action : pair nothing action) 280 (tokens : expression tokens (sourceGateLayoutIndented column)) 281 input) 282 (sourceGateDoBindHead? input) 283 284 sourceGateParseDoNext expression indentedExpression column input = 285 lazyBool 286 (_ : parserThen sourceGateSkipNestedNewlines 287 (sourceGateParseDoStatement expression indentedExpression column) 288 input) 289 (_ : parserReplyFail 290 (sourceGateExpected "do statement" t t) input false false) 291 (sourceGateDoSameColumn? input column) 292 293 sourceGateParseDoFirst expression indentedExpression keyword operator input = 294 lazyList 295 (_ : parserReplyFail 296 (parserDiagnostic 40 "indented do block" t t t) input false false) 297 (token rest : 298 lazyBool 299 (_ : parserBind 300 (sourceGateParseDoStatement expression indentedExpression 301 (sourcePositionColumn (sourceTokenStart token))) 302 (first : parserBind 303 (parserMany (sourceGateParseDoNext expression indentedExpression 304 (sourcePositionColumn (sourceTokenStart token)))) 305 (remaining : (nextInput : 306 lazyMaybe 307 (_ : parserReplyOk 308 (sourceAstDo keyword operator (pair first remaining) 309 (sourceAstDoStatementValue 310 (foldl (_ statement : statement) first remaining))) 311 nextInput false false) 312 (name : parserReplyFail 313 (parserDiagnostic 40 "do final expression" t 314 (sourceTokenStart name) t) 315 nextInput false false) 316 (sourceAstDoStatementBinder 317 (foldl (_ statement : statement) first remaining))))) 318 input) 319 (_ : parserReplyFail 320 (parserDiagnostic 40 "indented do block" 321 (sourceTokenKind token) (sourceTokenStart token) t) 322 input false false) 323 (not? (lte_? (sourcePositionColumn (sourceTokenStart token)) 1))) 324 input 325 326 sourceGateParseDo expression indentedExpression atom input = 327 parserBind (sourceGateExpect sourceTokenDo) (keyword : 328 parserThen sourceGateSkipNestedNewlines 329 (parserBind atom (operator : 330 parserThen (sourceGateExpect sourceTokenNewline) 331 (parserThen sourceGateSkipNestedNewlines 332 (sourceGateParseDoFirst expression indentedExpression 333 keyword operator))))) input 334 335 -- Alternatives use the reusable parser protocol. A malformed opened group 336 -- has consumed input, so parserOr propagates its failure rather than silently 337 -- retrying the atom error or another token kind. 338 sourceGateParseAtom_ self expression mode = 339 parserOr (sourceGateParseCase expression mode) (parserOr 340 (sourceGateParseDo expression 341 (column tokens : expression tokens (sourceGateLayoutIndented column)) 342 (self expression sourceGateLayoutTop)) 343 (parserOr 344 (sourceGateParseLet (tokens : expression tokens mode) 345 (column tokens : expression tokens (sourceGateLayoutIndented column)) (snd mode)) 346 (parserOr 347 (parserMap sourceAstLeaf (sourceGateExpect sourceTokenT)) 348 (parserOr 349 (parserMap sourceAstName (sourceGateExpect sourceTokenName)) 350 (parserOr 351 (parserMap sourceAstNumber (sourceGateExpect sourceTokenNumber)) 352 (parserOr 353 (parserMap sourceAstString (sourceGateExpect sourceTokenString)) 354 (parserOr 355 (sourceGateParseGroup 356 (tokens : expression tokens sourceGateLayoutNested)) 357 (parserOr 358 (sourceGateParseList 359 (self expression sourceGateLayoutNested)) 360 sourceGateAtomError)))))))) 361 362 sourceGateParseAtom = (expression mode input : 363 y sourceGateParseAtom_ expression mode input) 364 365 -- Only a successful atom consumes another operand. A close paren, colon or 366 -- newline is left intact for the enclosing parser; an opened but malformed 367 -- group propagates its consumed failure instead of silently ending the app. 368 -- A newline is a continuation only inside a delimiter and only when a 369 -- following token can start an atom. Looking ahead prevents a newline before 370 -- ')' or 'where' from becoming a committed atom failure. 371 sourceGateAtomStarts? kind = 372 or? (equal? kind sourceTokenT) 373 (or? (equal? kind sourceTokenName) 374 (or? (equal? kind sourceTokenNumber) 375 (or? (equal? kind sourceTokenString) 376 (or? (equal? kind sourceTokenOpen) 377 (or? (equal? kind sourceTokenLeftBracket) 378 (or? (equal? kind sourceTokenLet) 379 (or? (equal? kind sourceTokenDo) (equal? kind sourceTokenCase)))))))) 380 381 -- mode = pair insideDelimiter baseColumn. A top-level baseColumn of zero 382 -- disables continuation; a nonzero column allows strictly deeper lines. 383 sourceGateLayoutTop = pair false 0 384 sourceGateLayoutNested = pair true 0 385 sourceGateLayoutIndented column = pair false column 386 387 sourceGateNewlineStarts_ self tokens predicate mode = 388 lazyList 389 (_ : false) 390 (token rest : 391 lazyBool 392 (_ : self rest predicate mode) 393 (_ : and? (predicate (sourceTokenKind token)) 394 (or? (fst mode) 395 (and? (not? (isZero_? (snd mode))) 396 (not? (lte_? (sourcePositionColumn (sourceTokenStart token)) 397 (snd mode)))))) 398 (equal? (sourceTokenKind token) sourceTokenNewline)) 399 tokens 400 401 sourceGateNewlineStarts? = (tokens predicate mode : 402 y sourceGateNewlineStarts_ tokens predicate mode) 403 404 -- Do not consume a newline until a matching token at an allowed indentation 405 -- is visible. This retains layout boundaries in parser remainders. 406 sourceGateAfterLayoutNewlines mode starts parser input = 407 lazyList 408 (_ : parser input) 409 (token rest : 410 lazyBool 411 (_ : lazyBool 412 (_ : parserThen sourceGateSkipNestedNewlines parser input) 413 (_ : parser input) 414 (sourceGateNewlineStarts? rest starts mode)) 415 (_ : parser input) 416 (equal? (sourceTokenKind token) sourceTokenNewline)) 417 input 418 419 sourceGateAppNext mode expression input = 420 sourceGateAfterLayoutNewlines mode sourceGateAtomStarts? 421 (sourceGateParseAtom expression mode) input 422 423 sourceGateAppTail_ tailSelf input mode expression acc consumed = 424 parserMatchReply 425 (diagnostic rest stepConsumed committed : 426 lazyBool 427 (_ : parserReplyFail diagnostic rest 428 (or? consumed stepConsumed) committed) 429 (_ : parserReplyOk acc input consumed false) 430 (or? stepConsumed committed)) 431 (atom rest stepConsumed committed : 432 tailSelf rest mode expression (sourceAstApply acc atom) true) 433 (sourceGateAppNext mode expression input) 434 435 sourceGateParseApplication mode expression input = 436 parserBind (sourceGateParseAtom expression mode) (first : 437 (rest : y sourceGateAppTail_ rest mode expression first false)) input 438 439 sourceGatePipeStarts? kind = 440 or? (equal? kind sourceTokenPipeBackward) 441 (equal? kind sourceTokenPipeForward) 442 443 sourceGateParsePipeOperator = 444 parserOr (sourceGateExpect sourceTokenPipeBackward) 445 (sourceGateExpect sourceTokenPipeForward) 446 447 sourceGateParsePipeSegment mode expression input = 448 parserBind 449 (sourceGateAfterLayoutNewlines sourceGateLayoutNested 450 sourceGatePipeStarts? sourceGateParsePipeOperator) 451 (operator : parserThen sourceGateSkipNestedNewlines 452 (parserMap (right : pair operator right) 453 (sourceGateParseApplication mode expression))) input 454 455 -- Application binds tighter than a left-associative pipe chain. Retain an 456 -- explicit located AST pipe; core resolution chooses the direction later. 457 sourceGateParsePipes mode expression input = 458 parserBind (sourceGateParseApplication mode expression) (first : 459 parserMap (segments : foldl 460 (left segment : sourceAstPipe (fst segment) left (snd segment)) 461 first segments) 462 (parserMany (sourceGateParsePipeSegment mode expression))) input 463 464 sourceGateExpr_ self input mode = 465 lazyBool 466 (_ : sourceGateParseLambda (tokens : self tokens mode) input) 467 (_ : parserBind 468 (sourceGateParsePipes mode self) 469 (body : 470 parserMap (suffix : lazyMaybe (_ : body) (local : local) suffix) 471 (parserOptional (sourceGateAfterLayoutNewlines sourceGateLayoutNested 472 (kind : equal? kind sourceTokenWhere) 473 (sourceGateParseWhere 474 (tokens : self tokens mode) 475 (column tokens : self tokens (sourceGateLayoutIndented column)) 476 body (snd mode))))) input) 477 (sourceGateLambdaHead? input) 478 479 sourceGateExpr = (input : y sourceGateExpr_ input sourceGateLayoutTop) 480 sourceGateExprIndented = (column input : 481 y sourceGateExpr_ input (sourceGateLayoutIndented column)) 482 483 parseGateTokens input = 484 parserBefore sourceGateExpr sourceGateEof input 485 486 parseGateSource = parserWithLexer lexGateSource parseGateTokens 487