stew.sire (43751B)
1 ; Copyright 2023 The Plunder Authors 2 ; Use of this source code is governed by a BSD-style license that can be 3 ; found in the LICENSE file. 4 5 #### stew <- plan 6 7 ;;;; stew.sire 8 ;;;; ========= 9 ;;;; 10 ;;;; This is a parser, printer, and compiler for Stew, the "Steward Language". 11 ;;;; Stew is an interim language between Sire and Heir. Stew is built 12 ;;;; using the Sire macro system but does not itself support further 13 ;;;; macro-extension, instead using the traditional parse, type-check, 14 ;;;; compiler flow. 15 ;;;; 16 ;;;; We wont both implementing these command-runes, since they don't 17 ;;;; need to be type-checked nor extended: 18 ;;;; 19 ;;;; - #### 20 ;;;; - ^-^ 21 ;;;; - :| 22 ;;;; 23 ;;;; Also, these type-system commands should only be used internally, 24 ;;;; and not available in stew programs: 25 ;;;; 26 ;;;; - [ ] #abstype 27 ;;;; - [ ] #backfill 28 ;;;; 29 ;;;; TODO: Parse all built-in command runes: 30 ;;;; 31 ;;;; - [x] =?= 32 ;;;; - [x] = 33 ;;;; - [x] * 34 ;;;; 35 ;;;; TODO: Parse all macro-defined commands: 36 ;;;; 37 ;;;; - [x] !! 38 ;;;; - [x] #mutual 39 ;;;; - [ ] #record 40 ;;;; - [ ] #data 41 ;;;; 42 ;;;; TODO: Parse all leaf-expressions: 43 ;;;; 44 ;;;; - [x] parse decimal literals 45 ;;;; - [x] parse hex literals 46 ;;;; - [x] identifiers (rejecting malformed ones) 47 ;;;; 48 ;;;; DONE: Parse all built-in expression runes: 49 ;;;; 50 ;;;; - [x] | - 51 ;;;; - [x] @ 52 ;;;; - [x] @@ 53 ;;;; - [x] & 54 ;;;; - [x] ? 55 ;;;; - [x] ?? 56 ;;;; - [x] ** 57 ;;;; - [x] ^ 58 ;;;; 59 ;;;; TODO: Parse all macro-defined expressions: 60 ;;;; 61 ;;;; - [x] #p 62 ;;;; - [x] #b 63 ;;;; - [x] #x 64 ;;;; - [x] % 65 ;;;; - [x] %% 66 ;;;; - [x] # (tabs) 67 ;;;; - [x] ## 68 ;;;; - [x] @ (lambda binds) 69 ;;;; - [x] @ (multi binds) 70 ;;;; - [x] ' 71 ;;;; - [x] ` 72 ;;;; - [x] && 73 ;;;; - [x] || 74 ;;;; - [x] == 75 ;;;; - [x] /= 76 ;;;; - [x] , (rows) 77 ;;;; - [x] , (tabs) 78 ;;;; - [x] ++ 79 ;;;; - [x] : 80 ;;;; - [x] ~ 81 ;;;; - [x] ~~ 82 ;;;; - [x] :: 83 ;;;; - [x] # (keywords) 84 ;;;; - [x] #case 85 ;;;; - [x] #mutrec 86 ;;;; - [x] #switch 87 ;;;; - [x] . (non-symbolic references) 88 ;;;; - [x] Correctly print non-symbol references. 89 ;;;; - [x] Fix inline annotations on function literals. 90 ;;;; - [ ] Make sure function literals support all details. 91 ;;;; - [x] RECORD(..) patterns 92 ;;;; 93 ;;;; TODO: Support non-atomic keys in tabs. 94 ;;;; 95 ;;;; TODO: Parse expressions that don't exist yet. 96 ;;;; 97 ;;;; - [ ] / ("has type") 98 ;;;; 99 ;;;; Parse other commands: 100 ;;;; 101 ;;;; - [x] > 102 ;;;; - [ ] \ 103 ;;;; - [ ] #typedef 104 ;;;; - [ ] #typeof 105 ;;;; - [ ] #printType 106 ;;;; - [x] #getenv 107 ;;;; - [x] #getState 108 ;;;; - [ ] #getKey 109 ;;;; - [ ] #getProp 110 ;;;; - [ ] #setProp 111 ;;;; - [ ] #hasProp 112 ;;;; - [ ] #getTypeNames 113 ;;;; 114 ;;;; - [x] Compile stew to sire. 115 ;;;; - [x] Write a macro that parses stew, compiles it to sire, and 116 ;;;; expands to that. 117 ;;;; - [x] Redefine all runes to invoke TheBigStewMacro. 118 ;;;; 119 ;;;; - [ ] Name resolution 120 ;;;; - [ ] Compile Sire into sire backend code. 121 ;;;; - [ ] Manually implement command instead of expanding to low-level 122 ;;;; Sire code. 123 ;;;; 124 ;;;; - [ ] Merge switch.sire and datatype.sire 125 ;;;; - [ ] Implement #openrecord (#case on records) 126 ;;;; - [ ] Merge (#switch / #openrecord / #case) into #case 127 ;;;; - [ ] #case supports multiple values. 128 ;;;; - [ ] #case supports recursive patterns. 129 ;;;; - [ ] Merge #record and #data 130 131 132 ;;; Imports ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 134 :| sire 135 :| sire_21_switch [readSwitchExp switchE] 136 :| sire_25_datatype [parseDatacase resolveDatacase makeDatacaseExpr] 137 :| mutrec [readMutRecExp genMutRecE] 138 :| types 139 140 141 ;;; Types ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 142 143 * # typedef Sym Nat ; TODO: newtype 144 * # typedef Chr Nat ; TODO: newtype 145 146 # data Pat 147 - PVAR=v Sym 148 - PSEQ=s Sym 149 - PALI=a Sym Pat 150 - PROW=r (Row Pat) 151 - PTAB=t (Tab Any Pat) 152 - POPN=o Sym 153 - PPIN=pin Pat 154 - PLAW=law Pat Pat Pat 155 156 # record ConCase 157 | CON_CASE Sym (Row Pat) Exp 158 159 # record StewFun 160 | FUN self:Sym tag:Nat mark:Bit args:(Row Pat) body:Exp 161 162 # data Cmd -legible 163 - CEXP Exp 164 - CPASS 165 - CCHAIN Cmd Cmd 166 - CMUTUAL (Row Cmd) 167 - CASSERT_EQL Exp Exp 168 - CASSERT Exp 169 - CANN TExp Pat Exp 170 - CBIND Pat Exp 171 172 # data Exp -legible 173 - EBED Any 174 - EREF Str 175 - EQUA Str Str 176 - ENAT Nat 177 - EPAD Pad 178 - EBAR Bar 179 - ESET (Set Any) 180 - EOR Exp Exp 181 - EAND Exp Exp 182 - EAPP Exp Exp 183 - EKET Exp Exp 184 - ELET Pat Exp Exp 185 - EREC Row-(Pat, Exp) Exp 186 - ELAM Bit (Str, Nat, Row Pat, Exp) 187 - ELIN Exp 188 - EROW (Row Exp) 189 - EUNT 190 - ETAB (Tab Nat Exp) 191 - ESWI Exp Exp (Tab Any Exp) 192 - ECAS Exp (Maybe Exp) (Row ConCase) 193 - EMUT Nat Exp Row-(Sym, Row Pat, Exp) 194 - EREX Rex 195 - EQRX RexWith-(Either Exp Exp) 196 - ECON Exp Exp 197 - ENIL 198 - EEQL (Row Exp) 199 - ENEQ Exp Exp 200 - E_GET_STATE 201 - E_GETENV 202 203 204 ;;; Printing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 205 206 > Any > Rex 207 = (showKey k) 208 | ifNot (isNat k) 209 | todo {TODO: Support non-nat keys when printing tab patterns} 210 @ isKey 211 | and (neq 0 k) 212 | barAll isAlpha (natBar k) 213 | WORD (if isKey k | showNat k) 0 214 215 =?= 'a (showKey %a) 216 =?= '5 (showKey 5) 217 =?= '0 (showKey 0) 218 219 > (v > Rex) > Tab Any v > Rex 220 = (showTab showVal tab) 221 | if (tabIsEmpty tab) '(#[]) 222 ^ NEST {,} _ 0 223 : [key val] < foreach (tabToPairs tab) 224 | SHUT {=} (showKey key, showVal val) 0 225 226 = (showSet set) 227 ^ PREF {%} [_] 0 228 ^ NEST {,} _ 0 229 | map showKey (setToRow set) 230 231 > Pat > Rex 232 = (showPat p) 233 # case p 234 - PVAR v | varE v 235 - PSEQ v | PREF {!} ,(varE v) 0 236 - PALI x y | SHUT {@} (showPat x, showPat y) 0 237 - PROW xs | NEST {,} (map showPat xs) 0 238 - PTAB xs | showTab showPat xs 239 - POPN n | rexSetHeir '(..) (varE n) 240 - PPIN p | ` @(PIN $(showPat p)) 241 - PLAW n a b | ` @(LAW $(showPat n) $(showPat a) $(showPat b)) 242 - _ | {invalid pattern} p 243 244 =?= (' #[]) 245 | showPat 246 | PTAB #[] 247 248 =?= '[x=x y=(!y)] 249 | showPat 250 | PTAB [x=(PVAR %x) y=(PSEQ %y)] 251 252 =?= '[x=(UNIT(..)) y=(!y)] 253 | showPat 254 | PTAB [x=(POPN %UNIT) y=(PSEQ %y)] 255 256 =?= ' x@[a b@[c !d]] 257 | showPat 258 | PALI (PVAR %x) 259 | PROW 260 ++ PVAR %a 261 ++ PALI (PVAR %b) 262 | PROW (PVAR {c}, PSEQ {d}) 263 264 > Row Rex > Rex 265 = (showSig rexes@[first]) 266 | if (len rexes == 1) first 267 | NEST {|} rexes 0 268 269 > (Exp > Rex) > Bit > StewFun > Rex 270 = (showFun showExp pin (FUN self tag mark args body)) 271 | if (self /= tag) 272 | todo {show lambdas where name is different from tag} 273 @ selfRex ^ if mark (PREF {**} [_] 0) (else _) 274 | varE self 275 @ argRexes | map showPat args 276 | ifz tag 277 | NEST {&} ,(showSig argRexes) | showExp body 278 | if pin 279 | NEST {??} ,(showSig (rowCons selfRex argRexes)) | showExp body 280 | else 281 | NEST {?} ,(showSig (rowCons selfRex argRexes)) | showExp body 282 283 > Sym > Row Pat > Rex 284 = (showCon cn pts) 285 | if (null pts) (varE cn) 286 ^ NEST {|} _ 0 287 | rowCons (varE cn) 288 | map showPat pts 289 290 > (Exp > Rex) > Maybe Exp > Row ConCase > Rex 291 = (showDatacases showExp f xs) 292 ^ _ (listFromRow xs) 293 ? (go xs) 294 : (cn,pts,b) xs 295 < listCase xs 296 # case f 297 - NONE | 0 298 - SOME fb | `(- _ $(showExp fb)) 299 @ rest (go xs) 300 | `((- $(showCon cn pts) $(showExp b))($rest)) 301 302 = (niceApp showExp e) 303 ^ _ e ~[] 304 ? (loop e acc) 305 # case e 306 - EAPP f x | loop f (showExp x)::acc 307 - _ | NEST {|} (listToRow (showExp e)::acc) 0 308 309 = (showCase showExp x f cs) 310 | NEST {#} (varE {case}, showExp x) 311 | showDatacases showExp f cs 312 313 > (Exp > Rex) > Maybe Exp > Row ConCase > Rex 314 = (showMutRecArms showExp arms) 315 ^ _ (listFromRow arms) 316 ? (go arms) 317 : [sym pats body] arms < listCase arms 0 318 @ symRex (varE sym) 319 ^ NEST {*} (_, showExp body) (go arms) 320 | if (null pats) 321 | {mutrec arm with no arguments} 322 | [{impossible!} {it makes no sense!}] 323 ^ NEST {|} (rowCons symRex _) 0 324 | map showPat pats 325 326 = (showMutRec showExp tag body arms) 327 | NEST {#} 328 ++ varE {mutrec} 329 ++ showExp (ENAT tag) 330 ++ showExp body 331 | showMutRecArms showExp arms 332 333 = (showSwitchArms showExp wild arms) 334 ^ _ (tabToPairList arms) 335 ? (go arms) 336 : [key exp] arms 337 < listCase arms 338 | NEST {*} (varE {_}, showExp wild) 0 339 ^ NEST {*} _ (go arms) 340 | (showKey key, showExp exp) 341 342 = (showSwitch showExp exp wild arms) 343 | NEST {#} 344 ++ varE {switch} 345 ++ showExp exp 346 | showSwitchArms showExp wild arms 347 348 = (rexSplice f rex) 349 | ifz rex | rex 350 | if (rexIsEmbd rex) | f | rexEmbd rex 351 | rexSetSons | map (rexSplice f) (rexSons rex) 352 | rexSetHeir | rexSplice f (rexHeir rex) 353 | rex 354 355 = (showQuasiQuotedRex showExp rex) 356 ^ rexSplice _ rex 357 & val 358 # case val 359 - LEFT l | PREF {$$} [showExp-l] 0 360 - RIGHT r | PREF {$} [showExp-r] 0 361 362 > Chr > Bit 363 (okIdnChar c)=(eql {_} c || isAlphaNum c) 364 365 > Bar > Bit 366 = (okIdn bar) 367 @ c (barIdx 0 bar) 368 | rowAnd 369 ++ not (barIsEmpty bar) 370 ++ not (isDigit c) 371 ++ barAll okIdnChar bar 372 373 (okIdnStr str)=(okIdn | natBar str) 374 375 = (showRef dot str) 376 @ bar (natBar str) 377 | if (okIdn bar) 378 | WORD str 0 379 | if (not (barIsEmpty bar) && barAll isPrint bar) 380 ^ PREF dot [_] 0 381 | TEXT str 0 382 | else 383 ^ PREF dot [_] 0 384 | WORD (showNat str) 0 385 386 = (showQua dot mod ref) 387 @ modBar (natBar mod) 388 @ refBar (natBar ref) 389 ^ SHUT dot _ 0 390 ++ | if (okIdn modBar) 391 | WORD mod 0 392 | if (not (barIsEmpty modBar) && barAll isPrint modBar) 393 | TEXT mod 0 394 | else 395 | WORD (showNat mod) 0 396 ++ | if (okIdn refBar) 397 | WORD ref 0 398 | if (not (barIsEmpty refBar) && barAll isPrint refBar) 399 | TEXT ref 0 400 | else 401 | WORD (showNat ref) 0 402 403 =?= `foo.bar | showQua {.} {foo} {bar} 404 =?= `{f o}.{b r} | showQua {.} {f o} {b r} 405 =?= `1.0 | showQua {.} 1 0 406 407 ; TODO: Fix loot printing for {...\{...}. 408 ; TODO: Fix vim highlighting for {...\{...}. 409 410 =?= 'abc | showRef {.} {abc} 411 =?= '(.0) | showRef {.} {} 412 =?= '(.1) | showRef {.} 1 413 =?= '(.{a c}) | showRef {.} {a c} 414 415 = (mkApp row) 416 | if (null row) 417 | die {mkApp: function application with no function} 418 | foldl EAPP (idx 0 row) (drop 1 row) 419 420 =?= 1 | mkApp [1] 421 =?= (EAPP 1 2) | mkApp [1 2] 422 =?= (EAPP (EAPP 1 2) 3) | mkApp [1 2 3] 423 =?= (EAPP (EAPP (EAPP 1 2) 3) 4) | mkApp [1 2 3 4] 424 425 = (showBind showExp [pat bind]) 426 | INFX "=" (showPat pat, showExp bind) 0 427 428 = (showBinds showExp binds) 429 | foldr (x y & rexSetHeir y x) 0 (map (showBind showExp) binds) 430 431 > Exp > Rex 432 = (showExp exp) 433 @ go showExp 434 # case exp 435 - EBED x | EMBD x 436 - EREF x | showRef {.} x 437 - EQUA m x | showQua {.} m x 438 - ENAT n | WORD showNat-n 0 439 - EPAD p | showPadLit p 440 - EBAR b | showBarLit b 441 - ESET ks | showSet ks 442 - EOR x y | INFX {||} (showExp x, showExp y) 0 443 - EAND x y | INFX {&&} (showExp x, showExp y) 0 444 - EAPP x y | niceApp go exp 445 - EKET b v | NEST {^} [(go b)] (go v) 446 - ELET n x b | NEST {@} (showPat n, go x) (go b) 447 - EREC vs b | if null-vs (go b) | NEST {@@} [(showBinds showExp vs)] (go b) 448 - ELAM pin fun | showFun go pin fun 449 - ELIN x | PREF {**} ,(showExp x) 0 450 - EROW xs | NEST {,} (map go xs) 0 451 - ETAB xs | showTab showExp xs 452 - EUNT | '() 453 - ECAS x f cs | showCase go x f cs 454 - EMUT t b as | showMutRec go t b as 455 - ESWI e f as | showSwitch go e f as 456 - EREX r | NEST {'} [r] 0 457 - EQRX r | NEST {`} [(showQuasiQuotedRex go r)] 0 458 - ECON x xs | INFX {::} (showExp x, showExp xs) 0 459 - ENIL | '(~[]) 460 - EEQL xs | INFX {==} (map showExp xs) 0 461 - ENEQ x y | INFX {/=} (showExp x, showExp y) 0 462 - E_GETENV | `(#getenv) 463 - E_GET_STATE | `(#getstate) 464 - _ | {showExp: Unknown syntax} exp 465 466 =?= ' (@ n 6516329)(@ fanc (**mkLaw n a b))(0 p#111 b#{asdf} (2 fanc)) 467 | showExp 468 | ELET (PVAR {n}) (ENAT %inc) 469 | ELET (PVAR {fanc}) 470 | foldl EAPP (ELIN | EREF %mkLaw) 471 ++ EREF %n 472 ++ EREF %a 473 ++ EREF %b 474 | EAPP 475 | EAPP 476 | EAPP (ENAT 0) (EPAD p#111) 477 | EBAR b#asdf 478 | EAPP (ENAT 2) 479 | EREF %fanc 480 481 =?= ' [%[0 a b] %[0] %[]] 482 | showExp 483 | EROW (map ESET [%[0 a b] %[0] %[]]) 484 485 =?= ' [#[] [a=3] [us=[() ()]]] 486 | showExp 487 | EROW (map ETAB [#[] [a=(ENAT 3)] [us=(EROW [EUNT EUNT])]]) 488 489 =?= ' (& (x y))x 490 | showExp 491 | ELAM FALSE 492 | FUN 0 0 FALSE (PVAR %x, PVAR %y) (EREF %x) 493 494 =?= ' (? (const x y))x 495 | showExp 496 | ELAM FALSE 497 | FUN {const} {const} FALSE (PVAR %x, PVAR %y) (EREF %x) 498 499 =?= ' (? (**const x y))x 500 | showExp 501 | ELAM FALSE 502 | FUN {const} {const} TRUE (PVAR %x, PVAR %y) (EREF %x) 503 504 =?= ' (^ (f _ y))x 505 | showExp 506 | EKET (mkApp (EREF %f, EREF %_, EREF %y)) 507 | EREF %x 508 509 510 ;;; Parsing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 511 512 > (Rex > Read Exp) > Rex > Read Exp 513 = (parseLet readExp rex err ok) 514 : binds body < readLet readExp rex err 515 | ok 516 ^ foldr _ body binds 517 & (sweetBind body) 518 # case sweetBind 519 - LEFT [lawName mark argPats lawBody] 520 ^ ELET (PVAR lawName) _ body 521 | ELAM FALSE 522 | FUN lawName lawName mark argPats lawBody 523 - RIGHT [bind valExp] 524 | ELET bind valExp body 525 526 > (Rex > Read Exp) > Rex > Read Exp 527 = (parseRec readExp rex err ok) 528 : binds body < readLet readExp rex err 529 ^ ok (EREC _ body) 530 : sweetBind < foreach binds 531 # case sweetBind 532 - LEFT [lawName mark argPats lawBody] 533 ++ PVAR lawName 534 ++ ELAM FALSE (FUN lawName lawName mark argPats lawBody) 535 - RIGHT [bind valExp] 536 | [bind valExp] 537 538 > (Rex > Read Exp) > Rex > Read Rex 539 = (parseCen rex err ok) 540 : eRes < readCenLit rex err 541 # case eRes 542 - LEFT val | ok (ENAT val) 543 - RIGHT set | ok (ESET set) 544 545 > (Rex > Read Exp) > Rex > Read Rex 546 = (parseCenCen rex err ok) 547 : set < readTallSet rex err 548 | ok (ESET set) 549 550 = (parseOrExp readExp rex err ok) 551 : tree < readInfixRight readExp {||} rex err 552 | ok (binTreeFold EOR tree) 553 554 = (parseAndExp readExp rex err ok) 555 : tree < readInfixRight readExp {&&} rex err 556 | ok (binTreeFold EAND tree) 557 558 = (readCom readExp rex err ok) 559 @ rune (rexRune rex) 560 @ kids (rexKids rex) 561 | if (and (not null-kids) (eql {=} (rexRune fst-kids))) 562 : tab < readWideTabLit readExp rex err 563 | ok (ETAB tab) 564 | else 565 : exps < rowTraverse (x k & readExp x err k) kids 566 | ok (EROW exps) 567 568 = (readHaxOutline rex err ok) 569 @ kids@[keywordRex] | rexKids rex 570 @ params | drop 1 kids 571 | if (null kids) 572 | err rex {# with no parameter} 573 : sym < readSymbol keywordRex err 574 | ok keywordRex sym params 575 576 = (checkKeyword result rex err ok) 577 | if (1 /= len (rexKids rex)) 578 | err rex {Unexpected parameters to keyword} 579 | ok result 580 581 > (Rex > Read Exp) > Rex > Read Exp 582 = (parseHaxExp readExp rex err ok) 583 @ kids (rexKids rex) 584 @ rune (rexRune rex) 585 | if ((1 == len kids) && ({,} == rexRune fst-kids)) 586 : tab < readWideTabLit readExp fst-kids err 587 | ok (ETAB tab) 588 ; 589 : symRex sym params 590 < readHaxOutline rex err 591 ; 592 # switch sym 593 * _ | err symRex {Unknown # keyword} 594 * {p} | readPadLit rex err (pad & ok (EPAD pad)) 595 * {b} | readBarLit rex err (pad & ok (EBAR pad)) 596 * {x} | readBarLit rex err (pad & ok (EBAR pad)) 597 * {getstate} | **checkKeyword E_GET_STATE rex err ok 598 * {getenv} | ok E_GETENV ; **checkKeyword E_GETENV rex err ok 599 * {mutrec} 600 : tag body arms < readMutRecExp readExp rex err 601 | ok (EMUT tag body arms) 602 * {switch} 603 : exp fallback arms < readSwitchExp readExp rex err 604 | ok (ESWI exp fallback arms) 605 * {case} 606 : val fb cases < parseDatacase readExp rex err 607 | ok | ECAS val fb 608 : [_ constr pats body] < foreach cases 609 | CON_CASE constr pats body 610 611 > (Rex > Read Exp) > Rex > Read Exp 612 = (parseSig readExp rex err ok) 613 : items < readWideListLit readExp rex err 614 | ok (listFoldr ECON ENIL items) 615 616 > (Rex > Read Exp) > Rex > Read Exp 617 = (parseSigSig readExp rex err ok) 618 : items < readTallListLit readExp rex err 619 | ok (listFoldr ECON ENIL items) 620 621 > (Rex > Read Exp) > Rex > Read Exp 622 = (parseColCol readExp rex err ok) 623 : tree < readInfixRight readExp {::} rex err 624 | ok (binTreeFold ECON tree) 625 626 > (Rex > Read Exp) > Rex > Read Exp 627 = (parseTisTis readExp rex err ok) 628 : items < readEqlExp readExp rex err 629 | ok (EEQL items) 630 631 > (Rex > Read Exp) > Rex > Read Exp 632 = (parseFasTis readExp rex err ok) 633 : x y < readNotEqlExp readExp rex err 634 | ok (ENEQ x y) 635 636 > (Rex > Read Exp) > Rex > Read Rex 637 = (parseHaxHax readExp rex err ok) 638 : tab < readTallTabLit readExp rex err 639 | ok (ETAB tab) 640 641 = (parseTik rex err ok) 642 @ kids (rexKids rex) 643 | ifNot (eql 1 | len kids) 644 | err rex {Expected something like '(rex)} 645 | ok 646 | EREX (idx 0 kids) 647 648 = (parseBak readExp rex err ok) 649 ; 650 @ (readValLeft rex err ok) 651 : exp < readExp rex err 652 | ok (LEFT exp) 653 ; 654 @ (readExpRight rex err ok) 655 : exp < readExp rex err 656 | ok (RIGHT exp) 657 ; 658 : quoted 659 < readQuasiQuotedRex readValLeft readExpRight rex err 660 ; 661 | ok (EQRX quoted) 662 663 = (readApp readExp rex err ok) 664 : exps < readFancyApp readExp rex err 665 | ok 666 | if (null exps) EUNT 667 | foldl EAPP (idx 0 exps) (drop 1 exps) 668 669 = (readKet readExp rex err ok) 670 @ kids (rexKids rex) 671 @ nKid (len kids) 672 | if (lth nKid 2) 673 | err rex {Expected something like (^ exp exp...)body} 674 @ bodyRex | get kids (dec nKid) 675 @ expRexes | take (dec nKid) kids 676 : bodyExps < rowTraverse (x k & readExp x err k) expRexes 677 : valExp < readExp bodyRex err 678 | ok | EKET (mkApp bodyExps) valExp 679 680 = (readPam readExp rex err ok) 681 @ kids (rexKids rex) 682 | if (len kids /= 2) (err rex {Bad lambda}) 683 @ [sigRex bodRex] kids 684 : pats < readBindSig sigRex err 685 : body < readExp bodRex err 686 | ok | ELAM FALSE | FUN 0 0 FALSE pats body 687 688 = (readWut readExp pinned rex err ok) 689 @ kids@[sigRex bodRex] (rexKids rex) 690 | if (len kids /= 2) (err rex {Bad lambda.}) 691 : func mark pats < readDestroyer sigRex err 692 : body < readExp bodRex err 693 | ok | ELAM pinned | FUN func func mark pats body 694 695 = (readLin readExp rex err ok) 696 @ kids@[expRex] 697 | rexKids rex 698 | if (len kids /= 1) 699 | err rex {Expected something like: **x} 700 : exp < readExp expRex err 701 | ok (ELIN exp) 702 703 = (readDot rex err ok) 704 @ kids (rexKids rex) 705 | if (len kids == 2) 706 : mod < readKey (fst kids) err 707 : ref < readKey (snd kids) err 708 | ok (EQUA mod ref) 709 | if (len kids /= 1) 710 | err rex {expected .key} 711 : key < readKey (fst kids) err 712 | ok (EREF key) 713 714 = (readCol readExp rex err ok) 715 : valExp oFunName pats bodyExp 716 < readColExp parseBinder readExp rex err 717 @ (nam, pin) 718 | fromSome (FALSE, {}) oFunName 719 | ok 720 | EAPP valExp 721 | ELAM pin 722 | FUN nam nam FALSE pats bodyExp 723 724 = leafExpect 725 } Expected something like 726 } 727 } foo 728 } 123 729 } 0xAF 730 731 = (getHexLit bar fall ret) 732 | if (neq b#0x | barTake 2 bar) fall 733 | getHexBar (barDrop 2 bar) fall ret 734 735 = (readLeaf readExp rex err ok) 736 @ txt | rexText rex 737 @ bar | natBar txt 738 @ heir | rexHeir rex 739 | ifNonZero heir 740 ; TODO: handle this case manually instead of re-entering the parser 741 ; on a fake input. Eventually, we'll want nice error messages and 742 ; always working directly with the actual input is needed for that. 743 ^ readExp _ err ok 744 | OPEN {#} (rexSetHeir 0 rex, heir) 0 745 # switch (rexStyle rex) 746 * {TEXT} | ok | ENAT txt 747 * {LINE} | ok | ENAT txt 748 * {WORD} | if (okIdn bar) (ok (EREF txt)) 749 @ bar (barFilter (neq {_}) bar) 750 ^ getNatStr (barNat bar) _ (compose ok ENAT) 751 ^ getHexLit bar _ (compose ok ENAT) 752 | err rex leafExpect 753 754 > Rex > Read Exp 755 = (readExp rex err ok) 756 # switch (rexType rex) 757 * {EMBD} | ok EBED-(rexGetEmbd rex) 758 * {LEAF} | readLeaf readExp rex err ok 759 * {NODE} 760 # switch (rexRune rex) 761 * {^} | readKet readExp rex err ok 762 * {|} | readApp readExp rex err ok 763 * {-} | readApp readExp rex err ok 764 * {&} | readPam readExp rex err ok 765 * {?} | readWut readExp FALSE rex err ok 766 * {:} | readCol readExp rex err ok 767 * {??} | readWut readExp TRUE rex err ok 768 * {**} | readLin readExp rex err ok 769 * {,} | readCom readExp rex err ok 770 * {++} | readOpenRow readExp rex err (compose ok EROW) 771 * {.} | readDot rex err ok 772 * {@} | parseLet readExp rex err ok 773 * {@@} | parseRec readExp rex err ok 774 * {#} | parseHaxExp readExp rex err ok 775 * {##} | parseHaxHax readExp rex err ok 776 * {~} | parseSig readExp rex err ok 777 * {~~} | parseSigSig readExp rex err ok 778 * {::} | parseColCol readExp rex err ok 779 * {==} | parseTisTis readExp rex err ok 780 * {/=} | parseFasTis readExp rex err ok 781 * {'} | parseTik rex err ok 782 * {`} | parseBak readExp rex err ok 783 * {%} | parseCen rex err ok 784 * {%%} | parseCenCen rex err ok 785 * {&&} | parseAndExp readExp rex err ok 786 * {||} | parseOrExp readExp rex err ok 787 * _ | err rex (strWeld {Unknown Stew Rune: } | rexRune rex) 788 789 > (Rex > Read Cmd) > (Rex > Read Exp) > Rex > Read Cmd 790 = (readHaxCmd readCmd rex err ok) 791 : symRex sym params < readHaxOutline rex err 792 # switch sym 793 * {mutual} 794 : cmds < rowTraverse (flip readCmd err) params 795 | ok (CMUTUAL cmds) 796 * _ 797 : exp < parseHaxExp readExp rex err 798 | ok (CEXP exp) 799 800 = (readAssertEqlCmd rex err ok) 801 @ kids (rexKids rex) 802 @ nKid (len kids) 803 | if (rexRune rex /= "=?=") 804 | err rex {Expected a {=?=} rune} 805 | if (nKid == 3) 806 @ [leftRex rightRex moreRex] kids 807 : left < readExp leftRex err 808 : right < readExp rightRex err 809 : cmd < readAssertEqlCmd moreRex err 810 | ok (CCHAIN (CASSERT_EQL left right) cmd) 811 | if (nKid == 2) 812 @ [leftRex rightRex] kids 813 : left < readExp leftRex err 814 : right < readExp rightRex err 815 | ok (CASSERT_EQL left right) 816 | else 817 | err rex {Expected two or three params} 818 819 = (readAssertCmd rex err ok) 820 @ sons (rexSons rex) 821 @ heir (rexHeir rex) 822 | if (rexRune rex /= "!!") 823 | err rex {Expected a {!!} rune} 824 | if (null sons) 825 | err rex {Expected at least one expression} 826 : exprs 827 < rowTraverse (son ret & readExp son err ret) sons 828 @ cmd | CASSERT (mkApp exprs) 829 | ifz heir | ok cmd 830 : more < readAssertCmd heir err 831 | ok (CCHAIN cmd more) 832 833 = (readChainCmd readCmd rex err ok) 834 : cmds < rowTraverse (kid ret & readCmd kid err ret) (rexKids rex) 835 | (| ok | foldr CCHAIN CPASS cmds) 836 837 = (readBindCmd rex err ok) 838 @ heir | rexHeir rex 839 @ kids | rexKids rex 840 @ badParams | err rex {expected two parameters (and maybe another bind)} 841 | if (len kids == 3) 842 | ifz heir badParams 843 : c1 < readBindCmd (rexSetHeir 0 rex) err 844 : c2 < readBindCmd heir err 845 | trk {chain},c1,c2 846 | ok (CCHAIN c1 c2) 847 | if (len kids /= 2) 848 | badParams 849 @ [sigRex bodyRex] kids 850 @ sigRune rexRune-sigRex 851 | if ((sigRune == {|}) || (sigRune == {-})) 852 : func mark pats < readDestroyer sigRex err 853 : body < readExp bodyRex err 854 ^ trk [res=_] (ok _) 855 | CBIND (PVAR func) 856 | ELAM TRUE 857 | FUN func func mark pats body 858 | else 859 : pat < parseBinder sigRex err 860 : body < readExp bodyRex err 861 | trk [out=(CBIND pat body)] 862 | ok (CBIND pat body) 863 864 = (readTypedCmd rex err ok) 865 : annTy bRex < parseTypeAnnotatedBinding rex err 866 : cmd < readBindCmd bRex err 867 # case cmd 868 - _ | err bRex {can only annotate single bind} 869 - CBIND p x | ok (CANN annTy p x) 870 871 > (Rex > Read Cmd) > (Rex > Read Exp) > Rex > Read Cmd 872 = (readCmd rex err ok) 873 # switch (rexRune rex) 874 * _ : exp < readExp rex err 875 | ok (CEXP exp) 876 * {#} | readHaxCmd readCmd rex err ok 877 * {=?=} | readAssertEqlCmd rex err ok 878 * {!!} | readAssertCmd rex err ok 879 * {*} | readChainCmd readCmd rex err ok 880 * {=} | readBindCmd rex err ok 881 * {>} | readTypedCmd rex err ok 882 883 ; Assumes that the input formatting matches the printers formatting, 884 ; except that OPEN-form example inputs will be converted to NEST-form 885 ; inputs, to void long lines on complex examples. 886 = (expRound rex) 887 @ expected | rexClose rex 888 @ out | readExp rex v2 showExp 889 | if (expected == out) 1 890 | OPEN {/=} [] 891 | OPEN {*} [out] 892 | OPEN {*} [expected] 893 | 0 894 895 !! expRound ' x 896 !! expRound ' .{||} 897 !! expRound ' .0 898 !! expRound ' .3 899 !! expRound ' 0 900 !! expRound ' (f x y) 901 !! expRound ' (**f x y) 902 !! expRound ' [p#101 p#{}] 903 !! expRound ' (& x)x 904 !! expRound ' (& (x y))x 905 !! expRound ' (? (id x))x 906 !! expRound ' (? (const x y))x 907 !! expRound ' (@ x 3)(x x x) 908 !! expRound ' (@@ (x = 3))x 909 !! expRound ' (@@ (x = 3)(y = 4))x 910 !! expRound ' (^ (f _ y))x 911 !! expRound ' (@ x [1 2])[x x] 912 !! expRound ' (@ [x y] [1 2])[y x] 913 !! expRound ' (@ z@[!x y] [1 2])(x y z) 914 !! expRound ' (# mutrec 3 (three 5))(* (three _) 3) 915 !! expRound ' (# mutrec 3 (three 5))(* (three _) 3)(* (four _ _) (inc 3)) 916 !! expRound ' (# switch 3)(* 3 3)(* 4 4)(* _ 9) 917 !! expRound ' #getenv 918 919 =?= '[x=3 y=4] 920 ^ readExp _ v2 showExp 921 ' #[x=3 y=4] 922 923 =?= '[x=3 y=4] 924 ^ readExp _ v2 showExp 925 ' #[{x}=3 {y}=4] 926 927 =?= ' (@ f (? (f x))[x x])x 928 ^ readExp _ v2 showExp 929 ' @ (f x) [x x] 930 | x 931 932 =?= ' (@ x 3)(@ y 4)(@ z 5)[x y z] 933 ^ readExp _ v2 showExp 934 ' @ = x 3 935 = y 4 936 = z 5 937 | [x y z] 938 939 =?= ' (# switch 3)(* 3 3)(* 4 4)(* _ 0) 940 ^ readExp _ v2 showExp 941 ' # switch 3 942 * 3 3 943 * 4 4 944 945 !! expRound 946 ' ? (span f r) 947 @ l (len r) 948 ^ (_ 0) 949 ? (loop i) 950 | if (eql i l) (v2 r v0) 951 | if (f (idx i r)) 952 | loop (inc i) 953 | v2 (take i r) (drop i r) 954 955 =?= '[x=3 y=4] 956 ^ readExp _ v2 showExp 957 ' ## =x 3 958 ## =y 4 959 960 =?= '[300000 (0 57005)] 961 ^ readExp _ v2 showExp 962 ' ++ 300_000 963 ++ 0 0xD_E_A_D 964 965 =?= '[3 (0 1)] 966 ^ readExp _ v2 showExp 967 ' ++ 3 968 | 0 1 969 970 !! expRound '((# case a)(- NONE 0)(- (SOME x) x)) 971 972 =?= ' %[0 1 2 a b c] 973 ^ readExp _ v2 showExp 974 ' %% a b c 975 %% 0 1 2 976 977 =?= ' (3 :: (4 :: (5 :: ~[]))) 978 ^ readExp _ v2 showExp 979 ' ~[3 4 5] 980 981 =?= ' (3 :: (4 :: (5 :: ~[]))) 982 ^ readExp _ v2 showExp 983 ' ~~ 3 984 ~~ 4 985 5 986 987 !! expRound '(3 :: (4 :: (5 :: 6))) 988 989 =?= '(3 :: (4 :: (5 :: 6))) 990 ^ readExp _ v2 showExp 991 ' :: 3 4 992 :: 5 993 :: 6 994 995 =?= '(3 == 4 == 5) 996 ^ readExp _ v2 showExp 997 ' (3 == 4 == 5) 998 999 =?= ' (3 /= 4) 1000 ^ readExp _ v2 showExp 1001 ' (3 /= 4) 1002 1003 =?= ' (1 && (2 && 3)) 1004 ^ readExp _ v2 showExp 1005 ' (1 && 2 && 3) 1006 1007 =?= ' (1 || (2 || 3)) 1008 ^ readExp _ v2 showExp 1009 ' (1 || 2 || 3) 1010 1011 !! expRound 1012 ' # case a 1013 - NONE 0 1014 - _ 1 1015 1016 =?= '(add (inc 2) (inc 383)) 1017 ^ readExp _ v2 showExp 1018 ' | add 1019 * inc 2 1020 * inc 0x17f 1021 1022 =?= '(add 2 (? (Foo x))(add x x)) 1023 ^ readExp _ v2 showExp 1024 ' : ?(Foo x) < add 2 1025 | add x x 1026 1027 =?= ' (^ (_ 3))(0 0) 1028 ^ readExp _ v2 showExp 1029 ' ^ _ 3 1030 | 0 0 1031 1032 =?= 'asdf 1033 ^ readExp _ v2 showExp 1034 ' .{asdf} 1035 1036 1037 ;;; Traversal ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1038 1039 ; TODO: Move these into the bootstrapping process? Maybe into 12_tab.sire? 1040 1041 = (tabTraverseState ss f tab ok) 1042 @ keys (tabKeysRow tab) 1043 @ vals (tabValsRow tab) 1044 : ss rexes < rowTraverseState ss f vals 1045 | ok ss (_MkTab keys rexes) 1046 1047 = (traverseTab f tab ok) 1048 @ keys (tabKeysRow tab) 1049 @ vals (tabValsRow tab) 1050 : rexes < rowTraverse f vals 1051 | ok (_MkTab keys rexes) 1052 1053 = (rexTraverseState ss f rex ok) 1054 | ifz rex 1055 | ok ss rex 1056 | if (rexIsEmbd rex) 1057 : ss newVal < f ss (rexEmbd rex) 1058 | ok ss (EMBD newVal) 1059 : ss heir < rexTraverseState ss f (rexHeir rex) 1060 | if (rexIsLeaf rex) 1061 | ok ss (rexSetHeir heir rex) 1062 : ss sons 1063 < ^ rowTraverseState ss _ (rexSons rex) 1064 & (ss son ret) 1065 | rexTraverseState ss f son ret 1066 | ok ss 1067 | rexSetHeir heir 1068 | rexSetSons sons 1069 | rex 1070 1071 1072 = (traverseRex f rex ok) 1073 : _ res 1074 < ^ rexTraverseState 0 _ rex 1075 & (ss rex ok) 1076 : rex < f rex 1077 | ok 0 rex 1078 | ok res 1079 1080 1081 = (traverseExp f exp ok) 1082 @ go (traverseExp f) 1083 # case exp 1084 - _ | {TODO: add this to traverseExp} exp 1085 - E_GETENV | f exp ok 1086 - E_GET_STATE | f exp ok 1087 - ENIL | f exp ok 1088 - EUNT | f exp ok 1089 - EBED _ | f exp ok 1090 - EREF _ | f exp ok 1091 - EQUA _ _ | f exp ok 1092 - ENAT _ | f exp ok 1093 - EPAD _ | f exp ok 1094 - EBAR _ | f exp ok 1095 - ESET _ | f exp ok 1096 - EREX r | f exp ok 1097 - EOR x y | rowTraverse go [x y] & [x y] | f (EOR x y) ok 1098 - EAND x y | rowTraverse go [x y] & [x y] | f (EAND x y) ok 1099 - EAPP x y | rowTraverse go [x y] & [x y] | f (EAPP x y) ok 1100 - EKET x y | rowTraverse go [x y] & [x y] | f (EKET x y) ok 1101 - ELET n x b | rowTraverse go [x b] & [x b] | f (ELET n x b) ok 1102 - ENEQ x y | rowTraverse go [x y] & [x y] | f (ENEQ x y) ok 1103 - ECON x z | rowTraverse go [x z] & [x z] | f (ECON x z) ok 1104 - EROW xs | rowTraverse go xs & xs | f (EROW xs) ok 1105 - EEQL xs | rowTraverse go xs & xs | f (EEQL xs) ok 1106 - ETAB kv | traverseTab go kv & kv | f (ETAB kv) ok 1107 - ELIN x | go x & x | f (ELIN x) ok 1108 - EREC vs b 1109 : b < go b 1110 : vs < ^ rowTraverse _ vs 1111 & ([pat expr] ret) 1112 : expr < go expr 1113 | ret [pat expr] 1114 | f (EREC vs b) ok 1115 - ELAM p (FUN n t m a b) 1116 : b < go b 1117 | f (ELAM p (FUN n t m a b)) ok 1118 - ECAS x fb cases 1119 : x < go x 1120 : fb 1121 < & ok 1122 # case fb 1123 - NONE | ok NONE 1124 - SOME e | go e (compose ok SOME) 1125 : cases 1126 < ^ rowTraverse _ cases 1127 & ([con params body] ok) 1128 : body < go body 1129 | ok [con params body] 1130 | f (ECAS x fb cases) ok 1131 - EMUT tab body arms 1132 : body < go body 1133 : arms 1134 < ^ rowTraverse _ arms 1135 & ([sym pats armBody] ok) 1136 : armBody < go armBody 1137 | ok [sym pats armBody] 1138 | f (EMUT tab body arms) ok 1139 - ESWI x fb arms 1140 : x < go x 1141 : fb < go fb 1142 : arms < traverseTab go arms 1143 | f (ESWI x fb arms) ok 1144 - EQRX rex 1145 : rex 1146 < ^ traverseRex _ rex 1147 & (embed ok) 1148 # case embed 1149 - LEFT cns 1150 : cns < go cns 1151 | ok (LEFT cns) 1152 - RIGHT splice 1153 : splice < go splice 1154 | ok (RIGHT splice) 1155 | f (EQRX rex) ok 1156 1157 = (traversePat f pat ok) 1158 # case pat 1159 - POPN _ | f pat ok 1160 - PVAR _ | f pat ok 1161 - PSEQ _ | f pat ok 1162 - PALI n p 1163 : p < traversePat f p 1164 | f (PALI n p) ok 1165 - PROW xs 1166 : xs < rowTraverse (traversePat f) xs 1167 | f (PROW xs) ok 1168 - PTAB kv 1169 : kv < traverseTab (traversePat f) kv 1170 | f (PTAB kv) ok 1171 - PPIN p 1172 : p < traversePat f p 1173 | f (PPIN p) ok 1174 - PLAW n a b 1175 : n < traversePat f n 1176 : a < traversePat f a 1177 : b < traversePat f b 1178 | f (PLAW n a b) ok 1179 - _ 1180 | {invalid pattern} pat 1181 1182 = (traverseCmd f cmd ok) 1183 @ go (traverseCmd f) 1184 # case cmd 1185 - CCHAIN x y 1186 : x < go x 1187 : y < go y 1188 | f (CCHAIN x y) ok 1189 - CANN t p x | f cmd ok 1190 - CBIND _ _ | f cmd ok 1191 - CPASS | f cmd ok 1192 - CASSERT_EQL _ _ | f cmd ok 1193 - CASSERT _ | f cmd ok 1194 - CEXP _ | f cmd ok 1195 - CMUTUAL branches | {TODO: traverseCmd supports #mutual} 1196 - _ | {TODO: missing branch in traverseCmd} cmd 1197 1198 1199 ;;; Resolution ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1200 1201 = (resolvePat ss err pat ok) 1202 ^ traversePat _ pat ok 1203 & (pat ok) 1204 # case pat 1205 - _ 1206 | ok pat 1207 - POPN constr 1208 @ rex (showPat pat) 1209 : _ _ bind < getBind constr ss rex err 1210 @ fieldNames (getProp bind {fieldNames}) 1211 | ifz fieldNames 1212 | err rex (strWeld {Unknown record constructor: } constr) 1213 | ok (PROW | map PVAR fieldNames) 1214 1215 = (resolveExp ss exp err ok) 1216 @ goPat (resolvePat ss err) 1217 ^ traverseExp _ exp ok 1218 & (exp ok) 1219 # case exp 1220 - ELET n x b 1221 : n < goPat n 1222 | ok (ELET n x b) 1223 - ELAM p (FUN n t m as b) 1224 : as < rowTraverse goPat as 1225 | ok | ELAM p (FUN n t m as b) 1226 - EMUT tag body arms 1227 : arms < ^ rowTraverse _ arms 1228 & ([sym pats exp] ret) 1229 : pats < rowTraverse goPat pats 1230 | ret [sym pats exp] 1231 | ok (EMUT tag body arms) 1232 - ECAS x fb cases 1233 : cases 1234 < ^ rowTraverse _ cases 1235 & ([con params body] ok) 1236 : params < rowTraverse goPat params 1237 | ok (CON_CASE con params body) 1238 | ok (ECAS x fb cases) 1239 - _ 1240 | ok exp 1241 1242 = (resolveCmd ss cmd err ok) 1243 ^ traverseCmd _ cmd ok 1244 & (cmd ok) 1245 # case cmd 1246 - CPASS | ok cmd 1247 - CCHAIN _ _ | ok cmd ; nested commands already processed 1248 - CANN t p x 1249 : x < resolveExp ss x err 1250 | ok (CANN t p x) 1251 - CBIND p x 1252 : x < resolveExp ss x err 1253 | ok (CBIND p x) 1254 - CEXP exp 1255 : exp < resolveExp ss exp err 1256 | ok (CEXP exp) 1257 - CASSERT x 1258 : x < resolveExp ss x err 1259 | ok (CASSERT x) 1260 - CASSERT_EQL f x 1261 : f < resolveExp ss f err 1262 : x < resolveExp ss x err 1263 | ok (CASSERT_EQL f x) 1264 - CMUTUAL branches 1265 | die {TODO: Resolve references in #mutual commands} 1266 - _ 1267 | {TODO: resolveCmd is mising a case} cmd 1268 1269 1270 ;;; Compiler ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1271 1272 1273 = (cQrx go st rex ok) 1274 : st rexWithSplices 1275 < ^ rexTraverseState st _ rex 1276 & (st embd ret) 1277 # case embd 1278 - LEFT cns 1279 : st rex < go st cns 1280 | ret st (LEFT rex) 1281 - RIGHT val 1282 : st rex < go st val 1283 | ret st (RIGHT rex) 1284 | ok st 1285 | splicedE rexWithSplices 1286 1287 = (cApp go st exps ok) 1288 : st rexes < rowTraverseState st go exps 1289 | ok st (appE rexes) 1290 1291 = (cRow go st exps ok) 1292 : st rexes < rowTraverseState st go exps 1293 | ok st (rowE rexes) 1294 1295 = (cTab go st exps ok) 1296 : st rexesTab < tabTraverseState st go exps 1297 | ok st (tabE rexesTab) 1298 1299 = (cEql go st exps ok) 1300 : st rexes < rowTraverseState st go exps 1301 @ (st, rex) | multiEqlE st rexes 1302 | ok st rex 1303 1304 = (cKet go st bodyExp valExp ok) 1305 : st bodyRex < go st bodyExp 1306 : st valRex < go st valExp 1307 | ok st (letE {_} valRex bodyRex) 1308 1309 = (cSwi go st x wild arms ok) 1310 @ isRowSwi 1311 | listAnd 1312 | listZipWith eql (listEnumFrom 0) (tabKeysList arms) 1313 ^ go st (mkApp _) ok 1314 | if isRowSwi | (EBED switch, x, wild, EROW (tabValsRow arms)) 1315 | else | (EBED tabSwitch, x, wild, ETAB arms) 1316 1317 = (cLam go st pin (FUN nam tag mark pats bodyExp) ok) 1318 : st bodyRex < go st bodyExp 1319 : st sig bodyRex < makeDestroyer st pats bodyRex 1320 ; 1321 @ bodyRex bodyRex 1322 ; 1323 | if (nam /= tag) 1324 | todo {support mis-match between name and tag} 1325 ; 1326 | if (pin && isZero tag) 1327 | todo {support pinned, anonymous lambdas} 1328 ; 1329 | ok st 1330 | ifz tag 1331 | lamE sig bodyRex 1332 | wutE pin mark nam sig bodyRex 1333 1334 = (cLet go st pat valExp bodExp ok) 1335 : st valRex < go st valExp 1336 : st bodRex < go st bodExp 1337 ; 1338 @ (st, bSeq, deps) | sequenceBinds st [[pat valRex]] 1339 ; 1340 | ok st 1341 | bindSeqE bSeq bodRex deps 1342 1343 = (cRec go st vs bodExp ok) 1344 : st bodRex < go st bodExp 1345 : st binds < ^ rowTraverseState st _ vs 1346 & (st [bindPat bindExp] ret) 1347 # case bindPat 1348 - _ | todo {support pattern matching in letrec bindings} 1349 - PVAR bindVar 1350 : st bindRex < go st bindExp 1351 | ret st [bindVar bindRex] 1352 | ok st (recE binds bodRex) 1353 1354 = (cMut go st coreTag bodExp arms ok) 1355 : st bodRex 1356 < go st bodExp 1357 : st armSpecs 1358 < ^ rowTraverseState st _ arms 1359 & (st [funName pats funBodExp] ok) 1360 : st funBodRex < go st funBodExp 1361 | ok st [funName pats funBodRex] 1362 : st resultRex 1363 < genMutRecE st coreTag bodRex armSpecs 1364 | ok st 1365 | rexClose ; todo: all macros expand to closed forms 1366 | resultRex 1367 1368 = (cCas go ss valExp oWildExp arms ok) 1369 @ rex (showExp | ECAS valExp oWildExp arms) 1370 ; 1371 ; This on is extra tricky because we need to lookup information from 1372 ; the environment, but we don't have that information here. 1373 ; 1374 ; I guess that needs to be passed in? 1375 ; 1376 ; Should this be resolved during type-checking? If so, where should 1377 ; the information be stored? 1378 ; 1379 ; Should the information be included in the datatype and filled in by 1380 ; another pass? 1381 ; 1382 : ss valRex < go ss valExp 1383 : ss oWildRex 1384 < & ret 1385 # case oWildExp 1386 - NONE | ret ss NONE 1387 - SOME wildExp : ss wildRex < go ss wildExp 1388 | ret ss (SOME wildRex) 1389 ; 1390 : ss branches 1391 < & ret 1392 ^ rowTraverseState ss _ arms ret 1393 & (ss (CON_CASE constr pats armExp) ret) 1394 : ss armRex < go ss armExp 1395 ; 1396 | ret ss [armRex constr pats armRex] 1397 ; 1398 : hasTag fun fbRex caseSpecs 1399 < resolveDatacase rex ss oWildRex branches (curry die) 1400 : ss exp 1401 < makeDatacaseExpr hasTag fun ss valRex fbRex caseSpecs 1402 ; 1403 | ok ss (rexClose exp) ; TODO: no open rune output 1404 1405 ; | CON_CASE con:Sym params:(Row Pat) body:Exp 1406 ; * ECAS=cas x:Exp fb:(Maybe Exp) cs:(Row ConCase) 1407 1408 > Tab Sym Nat > Tab Nat Any > Nat > Exp > (Nat, Exp) 1409 = (compileExp ss exp) 1410 ^ : ss rex < _ ss exp 1411 | (ss, rexClose rex) 1412 ? (go ss exp ok) 1413 # case exp 1414 - ENIL | ok ss (cnsE 0) 1415 - EUNT | ok ss (cnsE 0) 1416 - EBED b | ok ss (cnsE b) 1417 - EREF r | ok ss (showRef {#.} r) 1418 - EQUA m r | ok ss (showQua {#.} m r) 1419 - ENAT n | ok ss (cnsE n) 1420 - EPAD n | ok ss (cnsE n) 1421 - EBAR n | ok ss (cnsE n) 1422 - ESET n | ok ss (cnsE n) 1423 - EREX r | ok ss (cnsE r) 1424 - EQRX r | cQrx go ss r ok 1425 - EOR x y | cApp go ss (EBED or, x, y) ok 1426 - EAND x y | cApp go ss (EBED and, x, y) ok 1427 - EAPP x y | cApp go ss (x, y) ok 1428 - ECON x xs | cApp go ss (EBED CONS, x, xs) ok 1429 - ENEQ x y | cApp go ss (EBED neq, x, y) ok 1430 - EEQL xs | cEql go ss xs ok 1431 - EROW xs | cRow go ss xs ok 1432 - ETAB xs | cTab go ss xs ok 1433 - EKET b x | cKet go ss b x ok 1434 - ESWI x fb arms | cSwi go ss x fb arms ok 1435 - ELAM p f | cLam go ss p f ok 1436 - ELET p v b | cLet go ss p v b ok 1437 - EREC vs b | cRec go ss vs b ok 1438 - EMUT t b as | cMut go ss t b as ok 1439 - ECAS v w as | cCas go ss v w as ok 1440 - ELIN x 1441 : ss rex < go ss x 1442 | ok ss (NEST {#**} [rex] 0) 1443 - E_GET_STATE | ok ss (cnsE ss) 1444 - E_GETENV | ok ss (cnsE | idx 2 ss) 1445 1446 = (compileCmd ss cmd) 1447 # case cmd 1448 - _ | {compileCmd: missing branch} cmd 1449 - CMUTUAL branches | die {TODO: compileCmd supports #mutual} 1450 - CEXP exp | compileExp ss exp 1451 - CPASS | (ss, OPEN {#*} [] 0) 1452 - CBIND p x 1453 @ (ss, xRex) | compileExp ss x 1454 | mkDefsC ss [[0 p xRex]] 1455 - CANN txp p x 1456 @ free | setToRow (txpFree txp) 1457 ; TODO: No crash! Validate input during parsing! 1458 : type < compileType ss free txp (rex msg & die [{lol} rex msg]) 1459 ; TODO type inference 1460 ; TODO record binding type 1461 | compileCmd ss (CBIND p x) 1462 - CCHAIN a b 1463 @ (ss, aRex) | compileCmd ss a 1464 @ (ss, bRex) | compileCmd ss b 1465 ^ (ss, _) | OPEN {#*} [aRex] bRex 1466 - CASSERT_EQL l r 1467 @ (ss, lRex) | compileExp ss l 1468 @ (ss, rRex) | compileExp ss r 1469 ^ (ss, _) | OPEN {#=?=} [lRex rRex] 0 1470 - CASSERT x 1471 @ (ss, xRex) | compileExp ss x 1472 ^ (ss, _) | OPEN {#=?=} [`1 xRex] 0 1473 1474 1475 ;;; Compiler Testing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1476 1477 = (comp ss exp) 1478 | compileExp ss exp 1479 1480 =?= (comp [5] (ENAT 0)) 1481 | [[5] `($$0)] 1482 1483 =?= (comp [5] (EAPP ENAT-0 ENAT-1)) 1484 | [[5] `(#| $$0 $$1)] 1485 1486 =?= (comp [5] (EEQL (ENAT 0, ENAT 1))) 1487 | [[5] `(#| $$eql $$0 $$1)] 1488 1489 =?= | comp [5] (EEQL (ENAT 0, ENAT 1, ENAT 2)) 1490 ++ [6] 1491 ++ `((#@ _g5 $$0)(#| $$and (#| $$eql _g5 $$1) (#| $$eql _g5 $$2))) 1492 1493 =?= | comp [5] (ELIN (EAPP ELIN-(EREF {id}) (ENAT 1))) 1494 ++ [5] 1495 ++ ` (#** (#| (#** id) $$1)) 1496 1497 =?= [[5] `(#| $$(%[a b c]) (#| $$(cow 3) (#| $$0 $$3) $$2 $$1))] 1498 | comp [5] 1499 | ETAB 1500 ## =a (ENAT 1) 1501 ## =b (ENAT 2) 1502 ## =c (EAPP ENAT-0 ENAT-3) 1503 1504 =?= ++ [5] 1505 ++ ` (#| (#| (#| $$tabSwitch foo) z) (#| $$(%[a b]) (#| $$(cow 2) y x))) 1506 ^ readExp _ (curry die) (comp [5]) 1507 ' (# switch foo)(* {a} x)(* {b} y)z 1508 1509 =?= ++ [5] 1510 ++ ` (#| (#| (#| $$tabSwitch foo) $$0) (#| $$(%[a]) (#| $$(cow 1) x))) 1511 ^ readExp _ (curry die) (comp [5]) 1512 ' (# switch foo)(* {a} x) 1513 1514 ; TODO Can these single-item switches be compiled to an if expression? 1515 1516 =?= [[5] '((#?? ({id} x))x)] 1517 | comp [5] 1518 | ELAM TRUE 1519 | FUN %id %id FALSE [(PVAR %x)] (EREF {x}) 1520 1521 =?= [[5] '((#?? (**{id} x))x)] 1522 | comp [5] 1523 | ELAM TRUE 1524 | FUN %id %id TRUE [(PVAR %x)] (EREF {x}) 1525 1526 =?= [[5] '((#& x)x)] 1527 | comp [5] 1528 | ELAM FALSE 1529 | FUN 0 0 FALSE [(PVAR %x)] (EREF {x}) 1530 1531 =?= [[5] '((#? ({f} x z))z)] 1532 | comp [5] 1533 | ELAM FALSE 1534 | FUN {f} {f} FALSE (PVAR %x, PVAR %z) (EREF {z}) 1535 1536 =?= ++ [7] 1537 ++ ` (#& _g5)(#@ _g6 _g5)(#@ x (#| $$(idx 0) _g6))(#@ z (#| $$(idx 1) _g6))z 1538 | comp [5] 1539 | ELAM FALSE 1540 | FUN 0 0 FALSE [(PROW (PVAR %x, PVAR %z))] (EREF {z}) 1541 1542 =?= ++ [6] 1543 ++ ` (#@ _g5 (#| $$(cow 2) $$2 $$1))(#@ x (#| $$(idx 0) _g5))x 1544 | comp [5] 1545 | ELET (PROW [(PVAR %x)]) 1546 | EROW (ENAT 1, ENAT 2) 1547 | EREF {x} 1548 1549 =?= ++ [5] 1550 ++ ` (#@ _ (#| $$0 $$1))(#| _ _) 1551 | comp [5] 1552 | EKET (EAPP EREF-{_} EREF-{_}) 1553 | EAPP ENAT-0 ENAT-1 1554 1555 =?= ++ [5] 1556 ++ ` (#@@ (= x (#| $$(cow 2) x $$1)))(#| car x) 1557 | comp [5] 1558 | EREC 1559 ++ ++ PVAR {x} 1560 ++ EROW (ENAT 1, EREF {x}) 1561 | EAPP (EREF {car}) 1562 | EREF {x} 1563 1564 =?= ++ [5] 1565 ++ ` (#@@ (= x (#| $$0 y))(= y (#| $$1 x)))(#| x y) 1566 | comp [5] 1567 | EREC 1568 ++ ++ PVAR {x} 1569 ++ EAPP ENAT-0 EREF-{y} 1570 ++ ++ PVAR {y} 1571 ++ EAPP ENAT-1 EREF-{x} 1572 | EAPP EREF-{x} EREF-{y} 1573 1574 ; gross 1575 =?= ++ [8] ;; TODO: This is wrong!!! _tag9 is used, so state should be at 10. 1576 ++ rexClose 1577 ` #@ _core5 1578 #? {lol} (_core5 _tag7 _arg6) 1579 #@ even 1580 #? (**even x) 1581 #| _core5 $$0 x 1582 #| $$switch _tag7 $$0 1583 #| $$(cow 1) (#@ x _arg6)x 1584 #@ even 1585 #? (**even x) 1586 #| _core5 $$0 x 1587 even 1588 | comp [5] 1589 | EMUT {lol} (EREF {even}) 1590 ++ (%even, [(PVAR %x)], EREF {x}) 1591 1592 = someProps 1593 | bt 1594 ++ {conTag},1 1595 ++ {conAri},1 1596 ++ {conFun},len 1597 ++ {conHas},FALSE 1598 ++ {conRaw},FALSE 1599 = noneProps 1600 | bt 1601 ++ {conTag},0 1602 ++ {conAri},0 1603 ++ {conFun},len 1604 ++ {conHas},FALSE 1605 ++ {conRaw},FALSE 1606 = scope 1607 ## =SOME | PIN [3 0 0 {REPL} {SOME} someProps] 1608 ## =NONE | PIN [4 0 0 {REPL} {NONE} noneProps] 1609 1610 = ssEx [5 {REPL} scope #[] btEmpty] 1611 1612 ; such a beauty 1613 =?= ++ put ssEx 0 8 1614 ++ rexClose 1615 ` #@ _g5 x 1616 #| $$switch (#| $$len _g5) $$1 1617 #| $$(cow 2) 1618 #@ _g6 x 1619 #@ x (#| $$(idx 0) _g6) 1620 x 1621 #@ _g7 x 1622 ($$0) 1623 | comp ssEx 1624 | ECAS EREF-{x} (SOME | ENAT 1) 1625 ++ CON_CASE {SOME} [(PVAR {x})] EREF-{x} 1626 ++ CON_CASE {NONE} [] ENAT-0 1627 1628 =?= ++ put ssEx 0 7 1629 ++ rexClose 1630 ` #@ _g5 sx 1631 #| $$tabSwitch (#| $$len _g5) $$0 1632 #| $$(%[1]) 1633 #| $$(cow 1) 1634 #@ _g6 sx 1635 #@ x (#| $$(idx 0) _g6) 1636 x 1637 | comp ssEx 1638 | ECAS (EREF {sx}) NONE 1639 ++ CON_CASE {SOME} ,(PVAR {x}) EREF-{x} 1640 1641 1642 ;;; Exports ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1643 1644 = (macaroniStew ss rex err ok) 1645 : stewExp < readExp rex err 1646 : stewExp < resolveExp ss stewExp err 1647 @ [ss rex] | compileExp ss stewExp 1648 | ok ss rex 1649 1650 = (macaroniStewCmd ss rex err ok) 1651 : stewCmd < readCmd rex err 1652 : stewCmd < resolveCmd ss stewCmd err 1653 @ [ss rex] | compileCmd ss stewCmd 1654 | ok ss rex 1655 1656 ( {^} #= macaroniStew ) 1657 ( {|} #= macaroniStew ) 1658 ( {-} #= macaroniStew ) 1659 ( {&} #= macaroniStew ) 1660 ( {?} #= macaroniStew ) 1661 ( {:} #= macaroniStew ) 1662 ( {??} #= macaroniStew ) 1663 ( {**} #= macaroniStew ) 1664 ( {,} #= macaroniStew ) 1665 ( {++} #= macaroniStew ) 1666 ( {.} #= macaroniStew ) 1667 ( {@} #= macaroniStew ) 1668 ( {@@} #= macaroniStew ) 1669 ( {##} #= macaroniStew ) 1670 ( {~} #= macaroniStew ) 1671 ( {~~} #= macaroniStew ) 1672 ( {::} #= macaroniStew ) 1673 ( {==} #= macaroniStew ) 1674 ( {/=} #= macaroniStew ) 1675 ( {'} #= macaroniStew ) 1676 ( {%} #= macaroniStew ) 1677 ( {%%} #= macaroniStew ) 1678 ( {&&} #= macaroniStew ) 1679 ( {||} #= macaroniStew ) 1680 ( {`} #= macaroniStew ) 1681 ( {=?=} #= macaroniStewCmd ) 1682 ( {!!} #= macaroniStewCmd ) 1683 ( {#} #= macaroniStewCmd ) 1684 ( {*} #= macaroniStewCmd ) 1685 ( {>} #= macaroniStewCmd ) 1686 ( {=} #= macaroniStewCmd ) 1687 1688 =?= 6 (@ a 3)(add a a) 1689 =?= 0 (3 == 4) 1690 =?= 1 (3 == 3) 1691 =?= 0 (3 == 3 == 4) 1692 1693 !! (3==3) 1694 !! eql 3 3 1695 !! tabHas {%} #getenv 1696 !! tabHas {sire} (get #getstate 3) ;; Modules table 1697 1698 #* x=3 y=4 z=9 1699 1700 * x y z 3=?=(dec y) 1701 1702 1703 ;;; Exports ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1704 1705 ^-^ 1706 ^-^ Pat 1707 ^-^ PVAR PSEQ PALI PROW PTAB 1708 ^-^ 1709 ^-^ ConCase 1710 ^-^ CON_CASE 1711 ^-^ 1712 ^-^ StewFun 1713 ^-^ FUN 1714 ^-^ 1715 ^-^ Cmd 1716 ^-^ CEXP CMUTUAL 1717 ^-^ 1718 ^-^ Exp 1719 ^-^ EBED EREF ENAT EPAD EBAR ESET EOR EAND EAPP EKET ELET EREC ELAM 1720 ^-^ ELIN EROW EUNT ETAB ESWI ECAS EMUT EQRX EREX ECON ENIL EEQL ENEQ 1721 ^-^ 1722 ^-^ showPat 1723 ^-^ readExp showExp 1724 ^-^ readCmd 1725 ^-^ compileExp 1726 ^-^ 1727 ^-^ ; MAKE. EVERYTHING. STEW. 1728 ^-^ 1729 ^-^ {^} {|} {-} {&} {?} {:} {??} {**} {,} {++} {.} {@} {@@} {##} 1730 ^-^ {~} {~~} {::} {==} {/=} {'} {%} {%%} {&&} {||} {`} {*} {>} {=} 1731 ^-^ 1732 1733 ;; also re-export from types.sire 1734 :| types 1735 , {#typedef} {#abstype} {#printType} {#typeof} {#backfill} 1736 {#record} {#data} {#case} 1737 Void Any Type 1738 Nat Pin Fun 1739 Ordering 1740 Bit Pad Char Str 1741 Word8 Word16 Word32 Word48 Word64 1742 Rex Read Read2 Read3 Read4 1743 Row List Set Tab 1744 Maybe Either 1745 Bar BarTree 1746 Unit Sing Pair Trip Quad Octo 1747 Row8 Row16