├── .github └── workflows │ └── tests.yaml ├── .gitignore ├── LICENSE ├── README.md ├── demos ├── minimal-state-machine │ ├── csv-browser.rkt │ ├── gui-layout.rkt │ ├── state-machine-compiler.rkt │ └── state-machine.rkt ├── mk-workshop-2024 │ ├── 01-example.rkt │ ├── 02-example-core.rkt │ ├── 03-mk-core.rkt │ ├── 04-mk-with-binding.rkt │ ├── 05-example-with-binding.rkt │ ├── 06-mk-with-sugar.rkt │ ├── 07-example-with-sugar.rkt │ ├── 08-mk-compiled.rkt │ ├── 09-example-compiled.rkt │ ├── 10-mk-with-check.rkt │ ├── 11-example-with-check.rkt │ ├── 12-example-matche.rkt │ ├── 13-routes.rkt │ ├── 14-foreign.rkt │ ├── 15-foreign-extension.rkt │ ├── 16-occurs-check.rkt │ ├── README.md │ ├── compile-with-check.rkt │ ├── compile.rkt │ ├── flights-data.rkt │ ├── mk-workshop-2024.pdf │ └── runtime.rkt ├── strumienta-talk │ ├── building-up-to-qi.rkt │ └── csv-demo │ │ ├── gui-layout.rkt │ │ ├── main.rkt │ │ ├── state-machine-compiler.rkt │ │ └── state-machine.rkt ├── symbol-tables.rkt ├── visser-symposium │ ├── csv-browser.rkt │ ├── gui-layout.rkt │ ├── state-machine-compiler.rkt │ └── state-machine.rkt ├── wg211 │ ├── 1-example.rkt │ ├── 2-example-core.rkt │ ├── 3-example-with-binding.rkt │ ├── 4-example-with-sugar.rkt │ ├── 5-example-compiled.rkt │ ├── 6-example-with-check.rkt │ ├── compile-with-check.rkt │ ├── compile.rkt │ ├── complete.rkt │ ├── mk-core.rkt │ ├── mk-with-binding.rkt │ ├── mk-with-check.rkt │ ├── mk-with-sugar.rkt │ ├── mk.rkt │ └── runtime.rkt └── zed-talk │ ├── macros.rkt │ ├── micro-mk-rt.rkt │ ├── micro-mk1.rkt │ ├── micro-mk2.rkt │ ├── micro-mk2b.rkt │ ├── micro-mk3.rkt │ ├── micro-mk4.rkt │ ├── micro-mk5.rkt │ ├── tradeoffs.rkt │ └── workbench.rkt ├── design ├── staged-minikanren.rkt ├── statechart-examples │ ├── statechart-counter.rkt │ ├── statechart-flight-booker.rkt │ ├── statechart-reddit.rkt │ ├── statechart-temp.rkt │ ├── statechart-timer.rkt │ ├── statechart-trafficlight.rkt │ ├── statechart-watch.rkt │ └── statecharts-login.rkt ├── statecharts-full.rkt └── statecharts-smaller.rkt ├── info.rkt ├── main.rkt ├── private ├── ee-lib │ ├── binding.rkt │ ├── datum-map.rkt │ ├── define.rkt │ ├── errors.rkt │ ├── flip-intro-scope.rkt │ ├── lift-disappeareds.rkt │ ├── lift-trampoline.rkt │ ├── main.rkt │ ├── persistent-id-table.rkt │ ├── syntax-category.rkt │ ├── syntax-datum.rkt │ ├── syntax-serializer.rkt │ └── test │ │ └── same-binding.rkt ├── runtime │ ├── binding-operations.rkt │ ├── binding-spec.rkt │ ├── compile.rkt │ ├── errors.rkt │ └── syntax-classes.rkt ├── syntax │ ├── compile │ │ ├── binding-spec.rkt │ │ ├── nonterminal-expander.rkt │ │ ├── pattern-var-reflection.rkt │ │ └── syntax-spec.rkt │ ├── env-reps.rkt │ ├── interface.rkt │ └── syntax-classes.rkt └── test │ ├── rebind-pattern-vars.rkt │ ├── sequence.rkt │ ├── set-bang.rkt │ └── simple-bspec.rkt ├── scribblings ├── common.rkt ├── main.scrbl ├── reference │ ├── compiling.scrbl │ ├── main.scrbl │ ├── specifying.scrbl │ └── versions.scrbl └── tutorial │ ├── basic-tutorial.scrbl │ ├── main.scrbl │ ├── multipass-tutorial.scrbl │ └── stlc-tutorial.scrbl ├── testing.rkt └── tests ├── #errors.rkt#1# ├── basic-langs ├── bind-syntax.rkt ├── block.rkt ├── define-star.rkt ├── define.rkt ├── expr.rkt ├── mutual-recursion.rkt ├── racket-macro.rkt ├── racket-var.rkt └── simple-match.rkt ├── binding-operations.rkt ├── colon-form.rkt ├── datum-matching.rkt ├── definition-interface.rkt ├── dsls ├── baby-peg.rkt ├── cmdline │ ├── cmdline.rkt │ ├── concepts.md │ ├── example.rkt │ ├── sugar.rkt │ └── tests.rkt ├── js │ ├── js.rkt │ ├── package.json │ └── runjs.js ├── match.rkt ├── matthews-findler │ ├── lump-inferred.rkt │ ├── lump.rkt │ └── ml.rkt ├── miniclass │ ├── README.md │ ├── class.rkt │ └── test.rkt ├── minikanren-binding-space-compile.rkt ├── minikanren-binding-space.rkt ├── minikanren-compile-defs-min.rkt ├── minikanren-compile-defs.rkt ├── minikanren-compile.rkt ├── minikanren-rs2e │ ├── example.rkt │ └── mk.rkt ├── minikanren.rkt ├── multipass.rkt ├── peg.rkt ├── peg │ ├── .gitignore │ ├── ARTIFACT.md │ ├── core.rkt │ ├── main.rkt │ ├── private │ │ ├── compile-alt-str.rkt │ │ ├── compile.rkt │ │ ├── forms.rkt │ │ ├── leftrec-check.rkt │ │ ├── runtime.rkt │ │ └── test │ │ │ └── case.rkt │ └── test │ │ ├── binops.rkt │ │ ├── colon-bind-shorthand.rkt │ │ ├── core-basic-tokens.rkt │ │ ├── core-text.rkt │ │ ├── define-in-let.rkt │ │ ├── define-peg-ast.rkt │ │ ├── figure-7.rkt │ │ ├── leftrec-oopsla.rkt │ │ ├── leftrec.rkt │ │ ├── lift-error.rkt │ │ ├── many-until.rkt │ │ ├── optimization.rkt │ │ ├── optional.rkt │ │ ├── raise-1.rkt │ │ ├── raise-2.rkt │ │ ├── return-example.rkt │ │ ├── sexpr.rkt │ │ ├── srcloc.rkt │ │ ├── sugar.rkt │ │ └── test-alt-str.rkt ├── peg2.rkt ├── qi-core.rkt ├── simply-typed-lambda-calculus.rkt ├── state-machine-for-tutorial.rkt ├── state-machine-oo │ ├── state-machine-compiler.rkt │ └── state-machine.rkt ├── statecharts │ └── statecharts.rkt ├── stlc-lang │ ├── main.rkt │ ├── program.rkt │ └── test.rkt ├── stlc-on-typed-racket.rkt ├── tiny-hdl │ ├── LICENSE │ ├── README.md │ ├── full-adder.rkt │ ├── half-adder.rkt │ └── hdl.rkt └── typed-peg │ ├── .gitignore │ ├── README.md │ ├── core.rkt │ └── private │ ├── compile.rkt │ ├── forms.rkt │ └── runtime.rkt ├── errors.rkt ├── global-reference-compiler.rkt ├── group-ellipsis.rkt ├── multi-import.rkt ├── multi-nest.rkt ├── nest-use-site-scope.rkt ├── nonterminal-prop.rkt ├── props.rkt ├── racket-body.rkt ├── racket-references.rkt ├── reference-compiler-with-application.rkt ├── rewrite-hygiene.rkt ├── symbol-collections.rkt └── variants.rkt /.github/workflows/tests.yaml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | run_tests: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v3 10 | - uses: Bogdanp/setup-racket@v1.9 11 | with: 12 | version: 8.11 13 | - run: raco pkg install -j 2 --auto 14 | - working-directory: ./tests/dsls/js 15 | run: npm install escodegen 16 | - run: raco test -j 2 -c syntax-spec-dev 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | **/compiled 2 | *~ 3 | **/.DS_Store 4 | tests/dsls/js/package-lock.json 5 | tests/dsls/js/node_modules 6 | doc/ 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Most of this repository is distributed under the Apache 2.0 and MIT licenses, 2 | like Racket. The user can choose the license under which they will be using the 3 | software. 4 | 5 | See the files 6 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 7 | and 8 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 9 | for the full text of the licenses. 10 | 11 | Some of the example and test DSL implementations are derivative works of other 12 | implementations of those DSLs and are thus licensed differently. See the LICENSE 13 | file in those subdirectories. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # syntax-spec 2 | 3 | A metalanguage for creating sophisticated DSLs in Racket. You provide a grammar and binding rules, and the metalanguage provides a front-end that checks binding, expands macros to your DSL core langauge, and provides tools for working with binding in your DSL's compiler. 4 | 5 | `syntax-spec` is used in the [Qi](https://github.com/drym-org/qi), [hosted-minikanren](https://github.com/michaelballantyne/hosted-minikanren), and [ocular-patdown](https://docs.racket-lang.org/ocular-patdown/Pattern-based_Updating.html) projects. 6 | This repository also includes a number of example DSL implementations: [peg](tests/dsls/peg), [cmdline](tests/dsls/cmdline), [miniKanren](tests/dsls/minikanren-rs2e), [miniclass](tests/dsls/miniclass), and [TinyHDL](tests/dsls/tiny-hdl). There is also a small [state machine DSL](demos/visser-symposium). 7 | 8 | If you'd like to learn more about syntax-spec, you can check out our [ICFP 2024 paper](https://mballantyne.net/publications/icfp2024.pdf) and associated [15-minute talk](https://youtu.be/F70QZaMoYJQ?t=10756), or my longer [demo](demos/mk-workshop-2024) at the 2024 miniKanren workshop. 9 | 10 | 11 | ## Installing the release 12 | 13 | A release is available on the Racket package server as [`syntax-spec-v3`](https://pkgs.racket-lang.org/package/syntax-spec-v3). 14 | 15 | This is still a prototype: future releases will likely contain breaking changes, and the documentation is incomplete. However, breaking changes will be released under an updated package name. 16 | 17 | To use the released package, install via: 18 | 19 | ``` 20 | raco pkg install syntax-spec-v3 21 | ``` 22 | 23 | and import as 24 | 25 | ``` 26 | (require syntax-spec-v3) 27 | ``` 28 | 29 | Its documentation is available on [the Racket documentation site](https://docs.racket-lang.org/syntax-spec-v3). 30 | 31 | 32 | ## Installing the development version 33 | 34 | To use the latest, unstable version, check out the Git repository, change directory into it, and run: 35 | 36 | 37 | ``` 38 | raco pkg install 39 | ``` 40 | 41 | Then import as 42 | 43 | ``` 44 | (require syntax-spec-dev) 45 | ``` 46 | 47 | Once installed, you can access the documentation via: 48 | 49 | ``` 50 | raco docs syntax-spec-dev 51 | ``` 52 | 53 | Note that the package name when installed this way is based on the directory name, so if you checked out this repository as the directory `syntax-spec`, you would use 54 | 55 | ``` 56 | raco pkg remove syntax-spec 57 | ``` 58 | 59 | to uninstall the package. 60 | 61 | 62 | -------------------------------------------------------------------------------- /demos/minimal-state-machine/csv-browser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (require "state-machine.rkt" 4 | "gui-layout.rkt" 5 | net/url 6 | csv-reading) 7 | 8 | ;; 9 | ;; UI elements 10 | ;; 11 | 12 | (define frame 13 | (new frame% 14 | [label "CSV Browser"] 15 | [min-width 400] 16 | [min-height 200])) 17 | 18 | (gui-layout frame 19 | (vertical-pane% 20 | (horizontal-pane% 21 | [stretchable-height #f] 22 | 23 | (text-field% 24 | #:as url-field 25 | [label "Data URL"] 26 | [init-value "https://people.sc.fsu.edu/~jburkardt/data/csv/addresses.csv"] 27 | [callback (lambda _ (send csv-controller url-change))]) 28 | 29 | (button% 30 | [label "Load"] 31 | [callback (lambda _ (send csv-controller load-click))])) 32 | 33 | (pane% 34 | #:as data-area 35 | 36 | (message% 37 | #:as url-message 38 | [label "Enter a URL"]) 39 | 40 | (message% 41 | #:as loading-message 42 | [label "Loading..."]) 43 | 44 | (message% 45 | #:as error-message 46 | [label "Error loading data"]) 47 | 48 | (list-box% 49 | #:as table 50 | [label ""] 51 | [columns (list "")] 52 | [choices (list)] 53 | [style (list 'single 'variable-columns)])))) 54 | 55 | ;; 56 | ;; UI actions 57 | ;; 58 | 59 | (define (set-display to-show) 60 | (send data-area change-children (lambda (_) (list to-show)))) 61 | 62 | (define (set-data data) 63 | (for ([i (range (- (length (send table get-column-labels)) 1))]) 64 | (send table delete-column 1)) 65 | (for ([i (range (- (length (car data)) 1))]) 66 | (send table append-column "")) 67 | (send table set-column-width 0 100 0 500) 68 | (define transposed (apply map list data)) 69 | (send/apply table set transposed)) 70 | 71 | 72 | ;; 73 | ;; Data loading 74 | ;; 75 | 76 | (define (load-data url) 77 | (thread 78 | (lambda () 79 | (define (on-error e) 80 | (queue-callback 81 | (lambda () 82 | (send csv-controller load-error)))) 83 | 84 | (with-handlers ([exn:fail? on-error]) 85 | (define data (csv->list (get-pure-port (string->url url)))) 86 | (queue-callback 87 | (lambda () 88 | (send csv-controller loaded data))))))) 89 | 90 | ;; 91 | ;; Controller via state machine DSL 92 | ;; 93 | 94 | (define csv-controller 95 | (machine 96 | #:initial-state no-data 97 | (state no-data 98 | (on-enter (set-display url-message)) 99 | (on (load-click) (-> loading)) 100 | (on (url-change) (-> no-data))) 101 | (state loading 102 | (on-enter (set-display loading-message) 103 | (load-data (send url-field get-value))) 104 | (on (loaded data) 105 | (set-data data) 106 | (-> display)) 107 | (on (load-error) (-> error)) 108 | (on (load-click) (-> loading)) 109 | (on (url-change) (-> no-data))) 110 | (state display 111 | (on-enter (set-display table)) 112 | (on (load-click) (-> loading)) 113 | (on (url-change) (-> no-data))) 114 | (state error 115 | (on-enter (set-display error-message)) 116 | (on (load-click) (-> loading)) 117 | (on (url-change) (-> no-data))) 118 | )) 119 | 120 | ;; 121 | ;; Run it. 122 | ;; 123 | 124 | (send frame show #t) 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /demos/minimal-state-machine/gui-layout.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide gui-layout) 4 | 5 | (require racket/class 6 | (for-syntax racket/base syntax/parse racket/syntax syntax/parse/class/paren-shape)) 7 | 8 | (define-syntax gui-layout 9 | (syntax-parser 10 | [(_ parent-name:id 11 | (class:id (~optional (~seq #:as element-name:id) 12 | #:defaults ([element-name (generate-temporary 'element)])) 13 | [~brackets arg-name:id arg-expr:expr] ... 14 | child ...) 15 | ...) 16 | #'(begin 17 | (define element-name 18 | (new class 19 | [parent parent-name] 20 | [arg-name arg-expr] ...)) 21 | ... 22 | (begin 23 | (gui-layout element-name child ...) 24 | ...))])) -------------------------------------------------------------------------------- /demos/minimal-state-machine/state-machine-compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-machine) 4 | 5 | (require syntax/parse/define (for-syntax syntax/parse racket/list)) 6 | 7 | (define-syntax compile-machine 8 | (syntax-parser 9 | #:datum-literals (machine state on-enter) 10 | [(_ initial-state 11 | (state state-name 12 | (on-enter action ...) 13 | e ...) 14 | ...) 15 | #'(let () 16 | (define machine% 17 | (class object% 18 | (define state #f) 19 | (define/public (set-state state%) 20 | (set! state (new state% [machine this]))) 21 | 22 | (compile-proxy-methods (e ... ...) state) 23 | 24 | (send this set-state initial-state) 25 | (super-new))) 26 | 27 | (define state-name 28 | (class object% 29 | (init-field machine) 30 | action ... 31 | (compile-event-method e machine) ... 32 | (super-new))) 33 | ... 34 | 35 | (new machine%))])) 36 | 37 | (define-syntax compile-proxy-methods 38 | (syntax-parser 39 | #:datum-literals (on ->) 40 | [(_ ((on (event-name . _) . _) ...) target) 41 | #:with (unique-event ...) 42 | (remove-duplicates (map syntax-e (attribute event-name))) 43 | #'(begin 44 | (define/public (unique-event . args) 45 | (send/apply target unique-event args)) 46 | ...)])) 47 | 48 | (define-syntax compile-event-method 49 | (syntax-parser 50 | #:datum-literals (on ->) 51 | [(_ (on (event-name arg ...) 52 | action ... 53 | (-> name)) 54 | machine) 55 | #'(define/public (event-name arg ...) 56 | action ... 57 | (send machine set-state name))])) -------------------------------------------------------------------------------- /demos/minimal-state-machine/state-machine.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide machine state on on-enter) 4 | 5 | (require "../../main.rkt") 6 | 7 | (syntax-spec 8 | (binding-class state-name) 9 | (binding-class event-var #:reference-compiler mutable-reference-compiler) 10 | 11 | (host-interface/expression 12 | (machine #:initial-state s:state-name d:machine-decl ...) 13 | #:binding (scope (import d) ... s) 14 | #'(compile-machine s d ...)) 15 | 16 | (nonterminal/exporting machine-decl 17 | (state n:state-name 18 | e:event-decl ...) 19 | #:binding (export n)) 20 | 21 | (nonterminal event-decl 22 | (on-enter e:racket-expr ...) 23 | (on (evt:id arg:event-var ...) 24 | e:racket-expr ... 25 | ((~datum ->) s:state-name)) 26 | #:binding (scope (bind arg) ... e ...))) 27 | 28 | (require syntax/parse/define (for-syntax syntax/parse racket/list)) 29 | 30 | (define-syntax compile-machine 31 | (syntax-parser 32 | #:datum-literals (machine state on-enter) 33 | [(_ initial-state 34 | (state state-name 35 | (on-enter action ...) 36 | e ...) 37 | ...) 38 | #'(let () 39 | (define machine% 40 | (class object% 41 | (define state #f) 42 | (define/public (set-state state%) 43 | (set! state (new state% [machine this]))) 44 | 45 | (compile-proxy-methods (e ... ...) state) 46 | 47 | (send this set-state initial-state) 48 | (super-new))) 49 | 50 | (define state-name 51 | (class object% 52 | (init-field machine) 53 | action ... 54 | (compile-event-method e machine) ... 55 | (super-new))) 56 | ... 57 | 58 | (new machine%))])) 59 | 60 | (define-syntax compile-proxy-methods 61 | (syntax-parser 62 | #:datum-literals (on ->) 63 | [(_ ((on (event-name . _) . _) ...) target) 64 | #:with (unique-event ...) 65 | (remove-duplicates (map syntax-e (attribute event-name))) 66 | #'(begin 67 | (define/public (unique-event . args) 68 | (send/apply target unique-event args)) 69 | ...)])) 70 | 71 | (define-syntax compile-event-method 72 | (syntax-parser 73 | #:datum-literals (on ->) 74 | [(_ (on (event-name arg ...) 75 | action ... 76 | (-> name)) 77 | machine) 78 | #'(define/public (event-name arg ...) 79 | action ... 80 | (send machine set-state name))])) 81 | 82 | (machine 83 | #:initial-state idle 84 | (state idle 85 | (on-enter (displayln "pay a dollar")) 86 | (on (dollar) 87 | (-> paid)) 88 | (on (select-item item) 89 | (displayln "you need to pay before selecting an item") 90 | (-> idle))) 91 | (state paid 92 | (on-enter (displayln "select an item")) 93 | (on (select-item item) 94 | (displayln (format "dispensing ~a" item)) 95 | (-> idle)))) 96 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/01-example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "08-mk-compiled.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (conde 7 | [(== l1 '()) (== l2 l3)] 8 | [(fresh (first rest res) 9 | (== l1 (cons first rest)) 10 | (== l3 (cons first res)) 11 | (appendo rest l2 res))])) 12 | 13 | (run 6 (l1 l2) 14 | (appendo l1 l2 (list 1 2 3 4))) 15 | 16 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/02-example-core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "03-mk-core.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (disj2 7 | (conj2 (== l1 '()) (== l2 l3)) 8 | (fresh1 (first) 9 | (fresh1 (rest) 10 | (fresh1 (res) 11 | (conj2 12 | (conj2 13 | (== l1 (cons first rest)) 14 | (== l3 (cons first res))) 15 | (appendo rest l2 res))))))) 16 | 17 | (run 6 (q) 18 | (fresh1 (l1) 19 | (fresh1 (l2) 20 | (conj2 (== q (cons l1 (cons l2 '()))) 21 | (appendo l1 l2 (cons 1 (cons 2 (cons 3 (cons 4 '()))))))))) 22 | 23 | 24 | 25 | 26 | 27 | 28 | ;; What if I make a grammar mistake? 29 | 30 | #;(run 1 (q) 31 | (== q 32 | (== q q))) 33 | 34 | (run 1 (q) 35 | (fresh1 (x) 36 | (+ 1 2))) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/03-mk-core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | (for-syntax syntax/parse)) 7 | 8 | ;; 9 | ;; Core syntax 10 | ;; 11 | 12 | (syntax-spec 13 | (nonterminal term 14 | n:number 15 | x:id 16 | ((~literal quote) ()) 17 | ((~literal cons) t1:term t2:term)) 18 | 19 | (nonterminal goal 20 | succeed 21 | fail 22 | 23 | (== t1:term t2:term) 24 | 25 | (disj2 g1:goal g2:goal) 26 | (conj2 g1:goal g2:goal) 27 | 28 | (fresh1 (x:id) b:goal) 29 | 30 | (r:id t:term ...+))) 31 | 32 | ;; 33 | ;; Interface macros 34 | ;; 35 | 36 | (syntax-spec 37 | (host-interface/definition 38 | (defrel (name:id x:id ...) 39 | g:goal) 40 | 41 | #:lhs [#'name] 42 | #:rhs [#''TODO]) 43 | 44 | (host-interface/expression 45 | (run n:racket-expr (q:id) g:goal) 46 | #''TODO)) 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/04-mk-with-binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | (for-syntax syntax/parse)) 7 | 8 | ;; 9 | ;; Core syntax 10 | ;; 11 | 12 | (syntax-spec 13 | (binding-class term-variable) ;; New 14 | (binding-class relation-name) ;; New 15 | 16 | (nonterminal term 17 | n:number 18 | x:term-variable 19 | ((~literal quote) ()) 20 | ((~literal cons) t1:term t2:term)) 21 | 22 | (nonterminal goal 23 | succeed 24 | fail 25 | 26 | (== t1:term t2:term) 27 | 28 | (disj2 g1:goal g2:goal) 29 | (conj2 g1:goal g2:goal) 30 | 31 | (fresh1 (x:term-variable) b:goal) 32 | #:binding (scope (bind x) b) ;; New 33 | 34 | (r:relation-name t:term ...+))) 35 | 36 | 37 | ;; 38 | ;; Interface macros 39 | ;; 40 | 41 | (syntax-spec 42 | (host-interface/definition 43 | (defrel (name:relation-name x:term-variable ...) g:goal) 44 | #:binding [(export name) (scope (bind x) ... g)] ;; New 45 | 46 | #:lhs [#'name] 47 | #:rhs [#'(pretty-print '(defrel (name x ...) g))]) 48 | 49 | (host-interface/expression 50 | (run n:expr (q:term-variable) g:goal) 51 | #:binding (scope (bind q) g) ;; New 52 | #'(pretty-print '(run n (q) g)))) 53 | 54 | 55 | 56 | 57 | (begin-for-syntax 58 | (require (only-in syntax-spec-dev/private/ee-lib/main show-var-numbers)) 59 | (show-var-numbers #t)) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/05-example-with-binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "04-mk-with-binding.rkt") 4 | 5 | ;; DrRacket understands binding structure now 6 | 7 | (defrel (appendo l1 l2 l3) 8 | (disj2 9 | (conj2 (== l1 '()) (== l2 l3)) 10 | (fresh1 (first) 11 | (fresh1 (rest) 12 | (fresh1 (res) 13 | (conj2 14 | (conj2 15 | (== l1 (cons first rest)) 16 | (== l3 (cons first res))) 17 | (appendo rest l2 res))))))) 18 | 19 | (run 5 (q) 20 | (fresh1 (l1) 21 | (fresh1 (l2) 22 | (conj2 (== q (cons l1 (cons l2 '()))) 23 | (appendo l1 l2 (cons 1 (cons 2 (cons 3 (cons 4 '()))))))))) 24 | 25 | 26 | ;; Unbound or incorrect references are an error now. 27 | 28 | #;(run 1 (q) 29 | (+ 1 2)) 30 | 31 | 32 | 33 | ;; The compiler receives alphatized syntax. 34 | 35 | (run 1 (q) 36 | (fresh1 (x) 37 | (fresh1 (x) 38 | (== q x)))) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/06-mk-with-sugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | (for-syntax syntax/parse)) 7 | 8 | ;; 9 | ;; Core syntax 10 | ;; 11 | 12 | (syntax-spec 13 | (binding-class term-variable) 14 | (binding-class relation-name) 15 | 16 | (extension-class term-macro) ;; New 17 | (extension-class goal-macro) ;; New 18 | 19 | (nonterminal term 20 | #:allow-extension term-macro ;; New 21 | 22 | n:number 23 | x:term-variable 24 | ((~literal quote) ()) 25 | ((~literal cons) t1:term t2:term)) 26 | 27 | (nonterminal goal 28 | #:allow-extension goal-macro ;; New 29 | 30 | succeed 31 | fail 32 | 33 | (== t1:term t2:term) 34 | 35 | (disj2 g1:goal g2:goal) 36 | (conj2 g1:goal g2:goal) 37 | 38 | (fresh1 (x:term-variable) b:goal) 39 | #:binding (scope (bind x) b) 40 | 41 | (r:relation-name t:term ...+))) 42 | 43 | 44 | ;; 45 | ;; Interface macros 46 | ;; 47 | 48 | (syntax-spec 49 | (host-interface/definition 50 | (core-defrel (name:relation-name 51 | x:term-variable ...) 52 | g:goal) 53 | #:binding [(export name) (scope (bind x) ... g)] 54 | 55 | #:lhs [#'name] 56 | #:rhs [#'(pretty-print '(defrel (name x ...) g))]) 57 | 58 | (host-interface/expression 59 | (core-run n:expr (q:term-variable) g:goal) 60 | #:binding (scope (bind q) g) 61 | #'(pretty-print '(run n (q) g)))) 62 | 63 | 64 | ;; 65 | ;; Surface syntax for terms 66 | ;; 67 | 68 | (define-dsl-syntax list term-macro 69 | (syntax-rules () 70 | [(list) '()] 71 | [(list a rest ...) 72 | (cons a (list rest ...))])) 73 | 74 | ;; 75 | ;; Surface syntax for goals 76 | ;; 77 | 78 | (define-dsl-syntax disj goal-macro 79 | (syntax-rules () 80 | ((disj) fail) 81 | ((disj g) g) 82 | ((disj g0 g ...) 83 | (disj2 g0 (disj g ...))))) 84 | 85 | (define-dsl-syntax conj goal-macro 86 | (syntax-rules () 87 | ((conj) succeed) 88 | ((conj g) g) 89 | ((conj g0 g ...) 90 | (conj2 g0 (conj g ...))))) 91 | 92 | (define-dsl-syntax fresh goal-macro 93 | (syntax-rules () 94 | ((fresh () g ...) (conj g ...)) 95 | ((fresh (x0 x ...) g ...) 96 | (fresh1 (x0) 97 | (fresh (x ...) 98 | g ...))))) 99 | 100 | (define-dsl-syntax conde goal-macro 101 | (syntax-rules () 102 | ((conde (g ...) ...) 103 | (disj (conj g ...) ...)))) 104 | 105 | 106 | ;; 107 | ;; Surface syntax for interface macros 108 | ;; 109 | 110 | (define-syntax defrel 111 | (syntax-rules () 112 | [(defrel (name x ...) g ...) 113 | (core-defrel (name x ...) (conj g ...))])) 114 | 115 | (define-syntax run ;; No binding rule, but hygienic. 116 | (syntax-rules () 117 | [(run n (x0 x ...) g ...) 118 | (run n q (fresh (x0 x ...) 119 | (== (list x0 x ...) q) g ...))] 120 | [(run n q g ...) 121 | (core-run n (q) (conj g ...))])) 122 | 123 | (define-syntax run* 124 | (syntax-rules () 125 | ((run* q g ...) (run #f q g ...)))) 126 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/07-example-with-sugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "06-mk-with-sugar.rkt") 4 | 5 | ;; The example uses syntactic sugar, but the compiler receives 6 | ;; core-language syntax. 7 | 8 | (defrel (appendo l1 l2 l3) 9 | (conde 10 | [(== l1 '()) (== l2 l3)] 11 | [(fresh (first rest res) 12 | (== l1 (cons first rest)) 13 | (== l3 (cons first res)) 14 | (appendo rest l2 res))])) 15 | 16 | (run* (l1 l2) 17 | (appendo l1 l2 (list 1 2 3 4))) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/08-mk-compiled.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | "compile.rkt" ;; New 7 | (for-syntax syntax/parse)) 8 | 9 | ;; 10 | ;; Core syntax 11 | ;; 12 | 13 | (syntax-spec 14 | (binding-class term-variable) 15 | (binding-class relation-name) 16 | 17 | (extension-class term-macro) 18 | (extension-class goal-macro) 19 | 20 | (nonterminal term 21 | #:allow-extension term-macro 22 | 23 | n:number 24 | x:term-variable 25 | ((~literal quote) ()) 26 | ((~literal cons) t1:term t2:term)) 27 | 28 | (nonterminal goal 29 | #:allow-extension goal-macro 30 | 31 | succeed 32 | fail 33 | 34 | (== t1:term t2:term) 35 | 36 | (disj2 g1:goal g2:goal) 37 | (conj2 g1:goal g2:goal) 38 | 39 | (fresh1 (x:term-variable) b:goal) 40 | #:binding (scope (bind x) b) 41 | 42 | (r:relation-name t:term ...+))) 43 | 44 | 45 | ;; 46 | ;; Interface macros 47 | ;; 48 | 49 | (syntax-spec 50 | (host-interface/definition 51 | (core-defrel (name:relation-name 52 | x:term-variable ...) 53 | g:goal) 54 | #:binding [(export name) (scope (bind x) ... g)] 55 | 56 | #:lhs [#'name] 57 | #:rhs [#'(compile-defrel name (x ...) g)]) ;; New 58 | 59 | (host-interface/expression 60 | (core-run n:expr (q:term-variable) g:goal) 61 | #:binding (scope (bind q) g) 62 | #'(compile-run n (q) g))) ;; New 63 | 64 | 65 | ;; 66 | ;; Surface syntax for terms 67 | ;; 68 | 69 | (define-dsl-syntax list term-macro 70 | (syntax-rules () 71 | [(list) '()] 72 | [(list a rest ...) 73 | (cons a (list rest ...))])) 74 | 75 | ;; 76 | ;; Surface syntax for goals 77 | ;; 78 | 79 | (define-dsl-syntax disj goal-macro 80 | (syntax-rules () 81 | ((disj) fail) 82 | ((disj g) g) 83 | ((disj g0 g ...) 84 | (disj2 g0 (disj g ...))))) 85 | 86 | (define-dsl-syntax conj goal-macro 87 | (syntax-rules () 88 | ((conj) succeed) 89 | ((conj g) g) 90 | ((conj g0 g ...) 91 | (conj2 g0 (conj g ...))))) 92 | 93 | (define-dsl-syntax fresh goal-macro 94 | (syntax-rules () 95 | ((fresh () g ...) (conj g ...)) 96 | ((fresh (x0 x ...) g ...) 97 | (fresh1 (x0) 98 | (fresh (x ...) 99 | g ...))))) 100 | 101 | (define-dsl-syntax conde goal-macro 102 | (syntax-rules () 103 | ((conde (g ...) ...) 104 | (disj (conj g ...) ...)))) 105 | 106 | 107 | ;; 108 | ;; Surface syntax for interface macros 109 | ;; 110 | 111 | (define-syntax defrel 112 | (syntax-rules () 113 | [(defrel (name x ...) g ...) 114 | (core-defrel (name x ...) (conj g ...))])) 115 | 116 | (define-syntax run 117 | (syntax-rules () 118 | [(run n (x0 x ...) g ...) 119 | (run n q (fresh (x0 x ...) 120 | (== (list x0 x ...) q) g ...))] 121 | [(run n q g ...) 122 | (core-run n (q) (conj g ...))])) 123 | 124 | (define-syntax run* 125 | (syntax-rules () 126 | ((run* q g ...) (run #f q g ...)))) 127 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/09-example-compiled.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "08-mk-compiled.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (conde 7 | [(== l1 '()) (== l2 l3)] 8 | [(fresh (first rest res) 9 | (== l1 (cons first rest)) 10 | (== l3 (cons first res)) 11 | (appendo rest l2 res))])) 12 | 13 | (run* (l1 l2) 14 | (appendo l1 l2 (list 1 2 3 4))) 15 | 16 | 17 | 18 | 19 | 20 | ;; What if I call a relation with the wrong number of arguments? 21 | #;(run* (l1 l2) 22 | (appendo l1 (list 1 2 3 4))) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/10-mk-with-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | "compile-with-check.rkt" ;; New 7 | (for-syntax syntax/parse)) 8 | 9 | ;; 10 | ;; Core syntax 11 | ;; 12 | 13 | (syntax-spec 14 | (binding-class term-variable) 15 | (binding-class relation-name) 16 | 17 | (extension-class term-macro) 18 | (extension-class goal-macro) 19 | 20 | (nonterminal term 21 | #:allow-extension term-macro 22 | 23 | n:number 24 | x:term-variable 25 | ((~literal quote) ()) 26 | ((~literal cons) t1:term t2:term)) 27 | 28 | (nonterminal goal 29 | #:allow-extension goal-macro 30 | 31 | succeed 32 | fail 33 | 34 | (== t1:term t2:term) 35 | 36 | (disj2 g1:goal g2:goal) 37 | (conj2 g1:goal g2:goal) 38 | 39 | (fresh1 (x:term-variable) b:goal) 40 | #:binding (scope (bind x) b) 41 | 42 | (r:relation-name t:term ...+))) 43 | 44 | 45 | ;; 46 | ;; Interface macros 47 | ;; 48 | 49 | (syntax-spec 50 | (host-interface/definition 51 | (core-defrel (name:relation-name 52 | x:term-variable ...) 53 | g:goal) 54 | #:binding [(export name) (scope (bind x) ... g)] 55 | 56 | #:lhs [(record-relation-arity! ;; New 57 | #'name 58 | (length (attribute x))) 59 | #'name] 60 | #:rhs [#'(compile-defrel name (x ...) g)]) 61 | 62 | (host-interface/expression 63 | (core-run n:expr (q:term-variable) g:goal) 64 | #:binding (scope (bind q) g) 65 | #'(compile-run n (q) g))) 66 | 67 | 68 | ;; 69 | ;; Surface syntax for terms 70 | ;; 71 | 72 | (define-dsl-syntax list term-macro 73 | (syntax-rules () 74 | [(list) '()] 75 | [(list a rest ...) 76 | (cons a (list rest ...))])) 77 | 78 | ;; 79 | ;; Surface syntax for goals 80 | ;; 81 | 82 | (define-dsl-syntax disj goal-macro 83 | (syntax-rules () 84 | ((disj) fail) 85 | ((disj g) g) 86 | ((disj g0 g ...) 87 | (disj2 g0 (disj g ...))))) 88 | 89 | (define-dsl-syntax conj goal-macro 90 | (syntax-rules () 91 | ((conj) succeed) 92 | ((conj g) g) 93 | ((conj g0 g ...) 94 | (conj2 g0 (conj g ...))))) 95 | 96 | (define-dsl-syntax fresh goal-macro 97 | (syntax-rules () 98 | ((fresh () g ...) (conj g ...)) 99 | ((fresh (x0 x ...) g ...) 100 | (fresh1 (x0) 101 | (fresh (x ...) 102 | g ...))))) 103 | 104 | (define-dsl-syntax conde goal-macro 105 | (syntax-rules () 106 | ((conde (g ...) ...) 107 | (disj (conj g ...) ...)))) 108 | 109 | 110 | ;; 111 | ;; Surface syntax for interface macros 112 | ;; 113 | 114 | (define-syntax defrel 115 | (syntax-rules () 116 | [(defrel (name x ...) g ...) 117 | (core-defrel (name x ...) (conj g ...))])) 118 | 119 | (define-syntax run 120 | (syntax-rules () 121 | [(run n (x0 x ...) g ...) 122 | (run n q (fresh (x0 x ...) 123 | (== (list x0 x ...) q) g ...))] 124 | [(run n q g ...) 125 | (core-run n (q) (conj g ...))])) 126 | 127 | (define-syntax run* 128 | (syntax-rules () 129 | ((run* q g ...) (run #f q g ...)))) 130 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/11-example-with-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module def racket 4 | (require "10-mk-with-check.rkt") 5 | (provide appendo) 6 | 7 | (defrel (appendo l1 l2 l3) 8 | (conde 9 | [(== l1 '()) (== l2 l3)] 10 | [(fresh (first rest res) 11 | (== l1 (cons first rest)) 12 | (== l3 (cons first res)) 13 | (appendo rest l2 res))]))) 14 | 15 | (module use racket 16 | (require "10-mk-with-check.rkt" 17 | (submod ".." def)) 18 | 19 | (run* (l1 l2) 20 | ;; Now arity mistakes get friendly errors. 21 | (appendo l1 (list 1 2 3 4)))) 22 | 23 | (require 'use) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/12-example-matche.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Our real, optimizing implementation! 4 | 5 | (require hosted-minikanren 6 | hosted-minikanren/racket-matche 7 | hosted-minikanren/inspect) 8 | 9 | ;; Let's see how extensions and optimizations fit together. 10 | 11 | (defrel (appendo l1 l2 l3) 12 | (disj 13 | (conj (== l1 '()) (== l2 l3)) 14 | (fresh (first rest res) 15 | (conj 16 | (== l1 (cons first rest)) 17 | (== l3 (cons first res)) 18 | (appendo rest l2 res))))) 19 | 20 | ;; We can define the same relation using a pattern matching extension. 21 | 22 | (defrel/matche (appendo/m l1 l2 l3) 23 | [('() l l)] 24 | [((cons first rest) l2 (cons first res)) 25 | (appendo/m rest l2 res)]) 26 | 27 | (begin 28 | ;; Shows the macro-expanded code that the miniKanren compiler receives. 29 | #;(print-relation-code appendo/m) 30 | 31 | ;; Shows the optimized code after constant prop and dead code elim. 32 | #;(print-relation-code/after-dead-code appendo/m)) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/13-routes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require hosted-minikanren) 4 | 5 | ;; Towards multi-language programming... 6 | 7 | (defrel (route origin end path) 8 | (conde 9 | [(== origin end) (== path '())] 10 | [(fresh (hop remainder) 11 | (== path (cons (list origin hop) remainder)) 12 | (absento origin remainder) 13 | (direct origin hop) 14 | (route hop end remainder))])) 15 | 16 | (defrel (direct a b) 17 | (conde 18 | [(== a "BOS") (== b "SEA")] 19 | [(== a "HOU") (== b "SLC")] 20 | [(== a "SEA") (== b "DEN")] 21 | [(== a "SEA") (== b "BOS")] 22 | [(== a "DEN") (== b "HOU")] 23 | [(== a "SLC") (== b "SFO")])) 24 | 25 | (run* (q) (route "SEA" "HOU" q)) 26 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/16-occurs-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require hosted-minikanren 4 | hosted-minikanren/inspect) 5 | 6 | ;; The occurs-check 7 | 8 | (run 1 (q) 9 | (== q (list q))) 10 | 11 | 12 | ;; Optimizing away the occurs-check 13 | 14 | (defrel (r1 a b) 15 | (fresh (x y) 16 | (== a (list 1 x)) 17 | (== b (list 1 y)) 18 | (== x y))) 19 | 20 | #;(print-relation-code/after-occurs-check r1) 21 | 22 | 23 | 24 | 25 | 26 | #;(defrel (r2 x y) 27 | (fresh (a b) 28 | (== x (cons '5 '6)) 29 | (goal-from-expression 30 | (void #| unknown racket code |#)) 31 | (== a b) 32 | (== y x))) 33 | 34 | #;(print-relation-code/after-occurs-check r2) 35 | 36 | 37 | 38 | 39 | 40 | ;; What if the representation of logic variables were exposed? 41 | 42 | #;(defrel (r3 x y) 43 | (fresh (a b) 44 | (== x (cons '5 '6)) 45 | (goal-from-expression 46 | (void (vector-set! x 1 (list y)))) 47 | (== a b) 48 | (== y x))) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/README.md: -------------------------------------------------------------------------------- 1 | # `syntax-spec` and `hosted-minikanren` demo at the 2024 miniKanren workshop 2 | 3 | This folder contains the [slides](mk-workshop-2024.pdf) and code examples from my talk "Hosted miniKanren: reconciling optimizing compilation and extensibility" [(video)](https://www.youtube.com/watch?t=18443&v=rLHUYRWgIGg) at the 2024 miniKanren workshop. 4 | 5 | The talk steps through the process of building a miniKanren implementation with syntax-spec, and shows off the way that our [hosted-miniKanren](https://github.com/michaelballantyne/hosted-minikanren) implementation benefits from the combination of macro-extensibility, optimizing compilation, and host-language interaction that syntax-spec enables. 6 | 7 | The files are named according to their order in the demo. Those from `12-example-matche.rkt` on rely on having [hosted-miniKanren](https://github.com/michaelballantyne/hosted-minikanren) installed, as well. 8 | -------------------------------------------------------------------------------- /demos/mk-workshop-2024/compile-with-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-defrel compile-run 4 | (for-syntax record-relation-arity!)) 5 | 6 | (require 7 | "runtime.rkt" 8 | syntax-spec-dev 9 | (for-syntax syntax/parse 10 | (only-in ee-lib compiled-from))) 11 | 12 | ;; New 13 | (begin-for-syntax 14 | (define-persistent-symbol-table relation-arity) 15 | 16 | (define (record-relation-arity! relname arity) 17 | (symbol-table-set! 18 | relation-arity relname arity))) 19 | 20 | 21 | (define-syntax compile-defrel 22 | (syntax-parser 23 | [(_ name (x ...) g) 24 | #'(lambda (x ...) 25 | (lambda (s) 26 | (lambda () 27 | (#%app (compile-goal g) s))))])) 28 | 29 | (define-syntax compile-run 30 | (syntax-parser 31 | [(_ n (q) g) 32 | #'(let ([q (var 'q)]) 33 | (map (reify q) 34 | (run-goal n (compile-goal g))))])) 35 | 36 | (define-syntax compile-goal 37 | (syntax-parser 38 | #:datum-literals (succeed fail == disj2 conj2 fresh1) 39 | [(_ succeed) 40 | #'succeed-rt] 41 | [(_ fail) 42 | #'fail-rt] 43 | [(_ (== t1 t2)) 44 | #`(==-rt (compile-term t1) (compile-term t2))] 45 | [(_ (disj2 g1 g2)) 46 | #`(disj2-rt (compile-goal g1) (compile-goal g2))] 47 | [(_ (conj2 g1 g2)) 48 | #`(conj2-rt (compile-goal g1) (compile-goal g2))] 49 | [(_ (fresh1 (x) b)) 50 | #`(call/fresh 'x (lambda (x) (compile-goal b)))] 51 | [(_ (relname t ...)) 52 | (define actual (length (attribute t))) ;; New 53 | (define expected 54 | (symbol-table-ref relation-arity #'relname)) 55 | 56 | (when (not (= actual expected )) 57 | (raise-syntax-error 58 | #f 59 | (format "wrong number of arguments to relation; actual ~a, expected ~a" actual expected) 60 | (compiled-from #'relname))) 61 | 62 | #'(relname (compile-term t) ...)])) 63 | 64 | (define-syntax compile-term 65 | (syntax-parser 66 | #:datum-literals (quote cons) 67 | [(_ n:number) 68 | #''n] 69 | [(_ x:id) 70 | #'x] 71 | [(_ (quote t)) 72 | #''t] 73 | [(_ (cons t1 t2)) 74 | #`(cons (compile-term t1) (compile-term t2))])) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-defrel compile-run) 4 | 5 | (require 6 | "runtime.rkt" 7 | (for-syntax syntax/parse)) 8 | 9 | (define-syntax compile-defrel 10 | (syntax-parser 11 | [(_ name (x ...) g) 12 | #'(lambda (x ...) 13 | (lambda (s) 14 | (lambda () 15 | (#%app (compile-goal g) s))))])) 16 | 17 | (define-syntax compile-run 18 | (syntax-parser 19 | [(_ n (q) g) 20 | #'(let ([q (var 'q)]) 21 | (map (reify q) 22 | (run-goal n (compile-goal g))))])) 23 | 24 | (define-syntax compile-goal 25 | (syntax-parser 26 | #:datum-literals (succeed fail == disj2 conj2 fresh1) 27 | [(_ succeed) 28 | #'succeed-rt] 29 | [(_ fail) 30 | #'fail-rt] 31 | [(_ (== t1 t2)) 32 | #`(==-rt (compile-term t1) (compile-term t2))] 33 | [(_ (disj2 g1 g2)) 34 | #`(disj2-rt (compile-goal g1) (compile-goal g2))] 35 | [(_ (conj2 g1 g2)) 36 | #`(conj2-rt (compile-goal g1) (compile-goal g2))] 37 | [(_ (fresh1 (x) b)) 38 | #`(call/fresh 'x (lambda (x) (compile-goal b)))] 39 | [(_ (relname t ...)) 40 | #'(relname (compile-term t) ...)])) 41 | 42 | (define-syntax compile-term 43 | (syntax-parser 44 | #:datum-literals (quote cons) 45 | [(_ n:number) 46 | #''n] 47 | [(_ x:id) 48 | #'x] 49 | [(_ (quote t)) 50 | #''t] 51 | [(_ (cons t1 t2)) 52 | #`(cons (compile-term t1) (compile-term t2))])) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/flights-data.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide download-flights-csv create-flights-table query-flight-rows) 4 | 5 | (require hosted-minikanren 6 | hosted-minikanren/demos/icfp2024/facts 7 | csv-reading 8 | racket/list 9 | net/url 10 | net/url-string 11 | db sql) 12 | 13 | (define SOURCE 14 | "https://raw.githubusercontent.com/jpatokal/openflights/master/data/routes.dat") 15 | 16 | ;; () -> [Listof [Listof String String]] 17 | ;; Should produce a list of flights, each flight a list matching the data schema 18 | (define (download-flights-csv) 19 | (for/list ([row (csv->list (get-pure-port (string->url SOURCE)))]) 20 | (list (third row) (fifth row)))) 21 | 22 | (define (create-flights-table v) 23 | (void)) 24 | 25 | (define-facts-table flights [flightfrom flightto] 26 | #:initial-data (download-flights-csv)) 27 | 28 | (defrel (direct a b) 29 | (query-facts flights a b)) 30 | 31 | (define (query-flight-rows conn a-arg b-arg) 32 | (run* (a b) 33 | (== a a-arg) 34 | (== b b-arg) 35 | (direct a b))) -------------------------------------------------------------------------------- /demos/mk-workshop-2024/mk-workshop-2024.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/michaelballantyne/syntax-spec/82687f30df3b2b364d4febcf9e40b06286ca4462/demos/mk-workshop-2024/mk-workshop-2024.pdf -------------------------------------------------------------------------------- /demos/strumienta-talk/building-up-to-qi.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | ;; (-> (U string? symbol?) string? (U string? symbol?)) 5 | (define (add-prefix name prefix) 6 | (cond 7 | [(string? name) (string-append prefix name)] 8 | [(symbol? name) (string->symbol 9 | (string-append prefix 10 | (symbol->string name)))])) 11 | 12 | (add-prefix 'x "1-") 13 | 14 | ;; Pattern: cond with predicates on same argument. 15 | 16 | (define-syntax-rule 17 | (switch (e) [p b] ...) 18 | (let ([v e]) (cond [(p v) b] ...))) 19 | 20 | (define (add-prefix2 name prefix) 21 | (switch (name) 22 | [string? (string-append prefix name)] 23 | [symbol? (string->symbol 24 | (string-append prefix 25 | (symbol->string name)))])) 26 | 27 | (add-prefix2 'x "2-") 28 | 29 | ;; Pattern: apply a sequence of transformations to a value 30 | 31 | (require threading) 32 | (define (add-prefix3 name prefix) 33 | (switch (name) 34 | [string? (string-append prefix name)] 35 | [symbol? (~>> name 36 | symbol->string 37 | (string-append prefix) 38 | string->symbol)])) 39 | 40 | (add-prefix3 'x "3-") 41 | 42 | ;; Notice common concept of a "flow" 43 | 44 | (module qi-example racket 45 | (require qi) 46 | 47 | (define (add-prefix4 name prefix) 48 | (switch (name) 49 | [string? (string-append prefix)] 50 | [symbol? (~>> symbol->string 51 | (string-append prefix) 52 | string->symbol)])) 53 | 54 | (add-prefix4 'x "4-")) 55 | 56 | (require 'qi-example) 57 | -------------------------------------------------------------------------------- /demos/strumienta-talk/csv-demo/gui-layout.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide gui-layout) 4 | 5 | (require racket/class 6 | (for-syntax racket/base syntax/parse racket/syntax syntax/parse/class/paren-shape)) 7 | 8 | (define-syntax gui-layout 9 | (syntax-parser 10 | [(_ parent-name:id 11 | (class:id (~optional (~seq #:as element-name:id) 12 | #:defaults ([element-name (generate-temporary 'element)])) 13 | [~brackets arg-name:id arg-expr:expr] ... 14 | child ...) 15 | ...) 16 | #'(begin 17 | (define element-name 18 | (new class 19 | [parent parent-name] 20 | [arg-name arg-expr] ...)) 21 | ... 22 | (begin 23 | (gui-layout element-name child ...) 24 | ...))])) -------------------------------------------------------------------------------- /demos/strumienta-talk/csv-demo/state-machine-compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-machine) 4 | 5 | (require syntax/parse/define (for-syntax syntax/parse)) 6 | 7 | (define-syntax compile-machine 8 | (syntax-parser 9 | #:datum-literals (machine) 10 | [(_ (machine #:initial-state initial-state 11 | #:states s ... 12 | #:shared-events e ...)) 13 | #'(let ([st #f]) 14 | (define common-handler 15 | (lambda (event) 16 | (compile-events e ... event [_ (error 'machine "no event handler matched for ~a" event)] st))) 17 | 18 | (compile-state s common-handler st) 19 | ... 20 | 21 | (set! st (initial-state)) 22 | (lambda (event) 23 | (st event)))])) 24 | 25 | (define-syntax compile-state 26 | (syntax-parser 27 | #:datum-literals (state on-enter) 28 | [(_ (state name 29 | (on-enter action ...) 30 | e ...) 31 | common-handler st) 32 | #'(define (name) 33 | action ... 34 | (lambda (event) 35 | (compile-events e ... event [_ (common-handler event)] st)))])) 36 | 37 | (define-syntax compile-events 38 | (syntax-parser 39 | #:datum-literals (on ->) 40 | [(_ (on (event-name arg ...) 41 | action ... 42 | (-> name)) 43 | ... 44 | event else-clause st) 45 | #'(match event 46 | [`(event-name ,arg ...) 47 | action ... 48 | (set! st (name))] 49 | ... 50 | else-clause)])) -------------------------------------------------------------------------------- /demos/strumienta-talk/csv-demo/state-machine.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide machine state on) 4 | 5 | (require "../../../main.rkt" "state-machine-compiler.rkt") 6 | 7 | (syntax-spec 8 | (binding-class state-name) 9 | 10 | (nonterminal/exporting state-spec 11 | (state name:state-name 12 | ((~datum on-enter) action:racket-expr ...) 13 | e:event-spec ...) 14 | #:binding (export name)) 15 | 16 | (nonterminal event-spec 17 | (on (name:id arg:id ...) 18 | action:racket-expr ... 19 | ((~datum ->) new-name:state-name))) 20 | 21 | (host-interface/expression 22 | (machine #:initial-state init:state-name 23 | #:states s:state-spec ... 24 | #:shared-events e:event-spec ...) 25 | #:binding (scope (import s) ... init e ...) 26 | 27 | #'(compile-machine (machine #:initial-state init 28 | #:states s ... 29 | #:shared-events e ...)))) -------------------------------------------------------------------------------- /demos/symbol-tables.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module lang racket 4 | (require "../main.rkt") 5 | (provide my-define my-ref Number List) 6 | 7 | (begin-for-syntax 8 | (define-persistent-symbol-table types)) 9 | 10 | (syntax-spec 11 | (nonterminal type 12 | Number 13 | (List t:type)) 14 | 15 | (binding-class my-var) 16 | 17 | (host-interface/definition 18 | (my-define x:my-var t:type) 19 | #:binding (export x) 20 | #:lhs [(symbol-table-set! types #'x (syntax->datum #'t)) 21 | #'x] 22 | #:rhs [#'7]) 23 | 24 | (host-interface/expression 25 | (my-ref x:my-var t:type) 26 | (when (not (equal? (symbol-table-ref types #'x) (syntax->datum #'t))) 27 | (raise-syntax-error #f "type error" #'x)) 28 | #'x))) 29 | 30 | (module def racket 31 | (require (submod ".." lang)) 32 | (provide x) 33 | (my-define x Number) 34 | ;; => 35 | #;(begin 36 | (define-syntax x (syntax-spec-binding my-var)) 37 | (define x^ 7))) 38 | 39 | (module ref racket 40 | (require (submod ".." lang) (rename-in (submod ".." def) [x y])) 41 | (my-ref y (List Number)) 42 | ;; => 43 | #;x^) 44 | 45 | (require 'ref) 46 | 47 | #;( 48 | (my-define x t) 49 | -> 50 | (begin 51 | (define x^ 7) 52 | (begin-for-syntax 53 | (free-id-table-set! ids #'x #'x^))) 54 | 55 | ) -------------------------------------------------------------------------------- /demos/visser-symposium/csv-browser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (require "state-machine.rkt" 4 | "gui-layout.rkt" 5 | net/url 6 | csv-reading) 7 | 8 | ;; 9 | ;; UI elements 10 | ;; 11 | 12 | (define frame 13 | (new frame% 14 | [label "CSV Browser"] 15 | [min-width 400] 16 | [min-height 200])) 17 | 18 | (gui-layout frame 19 | (vertical-pane% 20 | (horizontal-pane% 21 | [stretchable-height #f] 22 | 23 | (text-field% 24 | #:as url-field 25 | [label "Data URL"] 26 | [init-value "https://people.sc.fsu.edu/~jburkardt/data/csv/addresses.csv"] 27 | [callback (lambda _ (send csv-controller url-change))]) 28 | 29 | (button% 30 | [label "Load"] 31 | [callback (lambda _ (send csv-controller load-click))])) 32 | 33 | (pane% 34 | #:as data-area 35 | 36 | (message% 37 | #:as url-message 38 | [label "Enter a URL"]) 39 | 40 | (message% 41 | #:as loading-message 42 | [label "Loading..."]) 43 | 44 | (message% 45 | #:as error-message 46 | [label "Error loading data"]) 47 | 48 | (list-box% 49 | #:as table 50 | [label ""] 51 | [columns (list "")] 52 | [choices (list)] 53 | [style (list 'single 'variable-columns)])))) 54 | 55 | ;; 56 | ;; UI actions 57 | ;; 58 | 59 | (define (set-display to-show) 60 | (send data-area change-children (lambda (_) (list to-show)))) 61 | 62 | (define (set-data data) 63 | (for ([i (range (- (length (send table get-column-labels)) 1))]) 64 | (send table delete-column 1)) 65 | (for ([i (range (- (length (car data)) 1))]) 66 | (send table append-column "")) 67 | (send table set-column-width 0 100 0 500) 68 | (define transposed (apply map list data)) 69 | (send/apply table set transposed)) 70 | 71 | 72 | ;; 73 | ;; Data loading 74 | ;; 75 | 76 | (define (load-data url) 77 | (thread 78 | (lambda () 79 | (define (on-error e) 80 | (queue-callback 81 | (lambda () 82 | (send csv-controller load-error)))) 83 | 84 | (with-handlers ([exn:fail? on-error]) 85 | (define data (csv->list (get-pure-port (string->url url)))) 86 | (queue-callback 87 | (lambda () 88 | (send csv-controller loaded data))))))) 89 | 90 | ;; 91 | ;; Controller via state machine DSL 92 | ;; 93 | 94 | (define csv-controller 95 | (machine 96 | #:initial-state no-data 97 | (state no-data 98 | (on-enter (set-display url-message))) 99 | (state loading 100 | (on-enter (set-display loading-message) 101 | (load-data (send url-field get-value))) 102 | (on (loaded data) 103 | (set-data data) 104 | (-> display)) 105 | (on (load-error) (-> error))) 106 | (state display 107 | (on-enter (set-display table))) 108 | (state error 109 | (on-enter (set-display error-message))) 110 | (on (load-click) (-> loading)) 111 | (on (url-change) (-> no-data)))) 112 | 113 | ;; 114 | ;; Run it. 115 | ;; 116 | 117 | (send frame show #t) 118 | 119 | 120 | 121 | -------------------------------------------------------------------------------- /demos/visser-symposium/gui-layout.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide gui-layout) 4 | 5 | (require racket/class 6 | (for-syntax racket/base syntax/parse racket/syntax syntax/parse/class/paren-shape)) 7 | 8 | (define-syntax gui-layout 9 | (syntax-parser 10 | [(_ parent-name:id 11 | (class:id (~optional (~seq #:as element-name:id) 12 | #:defaults ([element-name (generate-temporary 'element)])) 13 | [~brackets arg-name:id arg-expr:expr] ... 14 | child ...) 15 | ...) 16 | #'(begin 17 | (define element-name 18 | (new class 19 | [parent parent-name] 20 | [arg-name arg-expr] ...)) 21 | ... 22 | (begin 23 | (gui-layout element-name child ...) 24 | ...))])) -------------------------------------------------------------------------------- /demos/visser-symposium/state-machine-compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-machine) 4 | 5 | (require syntax/parse/define (for-syntax syntax/parse racket/list)) 6 | 7 | (define-syntax compile-machine 8 | (syntax-parser 9 | #:datum-literals (machine state on-enter) 10 | [(_ initial-state 11 | (state state-name 12 | (on-enter action ...) 13 | e ...) 14 | ... 15 | common-e ...) 16 | #:with (all-events ...) (unique-event-names #'(e ... ... common-e ...)) 17 | #'(let () 18 | (define machine% 19 | (class object% 20 | (define state #f) 21 | (define/public (set-state state%) 22 | (set! state (new state% [machine this]))) 23 | 24 | (compile-proxy-method all-events state) 25 | ... 26 | 27 | (send this set-state initial-state) 28 | (super-new))) 29 | 30 | (define common% 31 | (class object% 32 | (init-field machine) 33 | 34 | (compile-event-method common-e machine) 35 | ... 36 | 37 | (super-new))) 38 | 39 | (define state-name 40 | (class common% 41 | (inherit-field machine) 42 | 43 | action 44 | ... 45 | 46 | (compile-event-method e machine) 47 | ... 48 | 49 | (super-new))) 50 | ... 51 | 52 | (new machine%))])) 53 | 54 | (begin-for-syntax 55 | (define (unique-event-names evt-stxs) 56 | (remove-duplicates (map event-name (syntax->list evt-stxs)) 57 | bound-identifier=?)) 58 | 59 | (define (event-name e) 60 | (syntax-parse e 61 | [(on (name . _) . _) #'name]))) 62 | 63 | (define-syntax compile-proxy-method 64 | (syntax-parser 65 | [(_ name target) 66 | #'(define/public (name . args) 67 | (send/apply target name args))])) 68 | 69 | (define-syntax compile-event-method 70 | (syntax-parser 71 | #:datum-literals (on ->) 72 | [(_ (on (event-name arg ...) 73 | action ... 74 | (-> name)) 75 | machine) 76 | #'(define/public (event-name arg ...) 77 | action ... 78 | (send machine set-state name))])) -------------------------------------------------------------------------------- /demos/visser-symposium/state-machine.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide machine state on on-enter) 4 | 5 | (require "../../main.rkt" "state-machine-compiler.rkt") 6 | 7 | (syntax-spec 8 | (binding-class state-name) 9 | 10 | (host-interface/expression 11 | (machine #:initial-state s:state-name d:machine-decl ...) 12 | #:binding (scope (import d) ... s) 13 | #'(compile-machine s d ...)) 14 | 15 | (nonterminal/exporting machine-decl 16 | (state n:state-name 17 | e:event-decl ...) 18 | #:binding (export n) 19 | e:event-decl) 20 | 21 | (nonterminal event-decl 22 | (on-enter e:racket-expr ...) 23 | (on (evt:id arg:racket-var ...) 24 | e:racket-expr ... 25 | ((~datum ->) s:state-name)) 26 | #:binding (scope (bind arg) ... e ...))) 27 | -------------------------------------------------------------------------------- /demos/wg211/1-example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "mk.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (conde 7 | [(== l1 '()) (== l2 l3)] 8 | [(fresh (first rest res) 9 | (== l1 (cons first rest)) 10 | (== l3 (cons first res)) 11 | (appendo rest l2 res))])) 12 | 13 | (run 6 (l1 l2) 14 | (appendo l1 l2 (list 1 2 3 4))) 15 | 16 | -------------------------------------------------------------------------------- /demos/wg211/2-example-core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "mk-core.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (disj2 7 | (conj2 (== l1 '()) (== l2 l3)) 8 | (fresh1 (first) 9 | (fresh1 (rest) 10 | (fresh1 (res) 11 | (conj2 12 | (conj2 13 | (== l1 (cons first rest)) 14 | (== l3 (cons first res))) 15 | (appendo rest l2 res))))))) 16 | 17 | (run 6 (q) 18 | (fresh1 (l1) 19 | (fresh1 (l2) 20 | (conj2 (== q (cons l1 (cons l2 '()))) 21 | (appendo l1 l2 (cons 1 (cons 2 (cons 3 (cons 4 '()))))))))) 22 | 23 | 24 | 25 | 26 | ;; What if I make a grammar mistake? 27 | 28 | (run 1 (q) 29 | (fresh1 (q) q)) -------------------------------------------------------------------------------- /demos/wg211/3-example-with-binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "mk-with-binding.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (disj2 7 | (conj2 (== l1 '()) (== l2 l3)) 8 | (fresh1 (first) 9 | (fresh1 (rest) 10 | (fresh1 (res) 11 | (conj2 12 | (conj2 13 | (== l1 (cons first rest)) 14 | (== l3 (cons first res))) 15 | (appendo rest l2 res))))))) 16 | 17 | (run 5 (q) 18 | (fresh1 (l1) 19 | (fresh1 (l2) 20 | (conj2 (== q (cons l1 (cons l2 '()))) 21 | (appendo l1 l2 (cons 1 (cons 2 (cons 3 (cons 4 '()))))))))) 22 | 23 | 24 | ;; DrRacket understands binding structure now, 25 | ;; and unbound references are errors. -------------------------------------------------------------------------------- /demos/wg211/4-example-with-sugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "mk-with-sugar.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (conde 7 | [(== l1 '()) (== l2 l3)] 8 | [(fresh (first rest res) 9 | (== l1 (cons first rest)) 10 | (== l3 (cons first res)) 11 | (appendo rest l2 res))])) 12 | 13 | (run* (l1 l2) 14 | (appendo l1 l2 (list 1 2 3 4))) 15 | 16 | (run 1 (q) 17 | (fresh (x) 18 | (fresh (x) 19 | (== q x)))) -------------------------------------------------------------------------------- /demos/wg211/5-example-compiled.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "mk.rkt") 4 | 5 | (defrel (appendo l1 l2 l3) 6 | (conde 7 | [(== l1 '()) (== l2 l3)] 8 | [(fresh (first rest res) 9 | (== l1 (cons first rest)) 10 | (== l3 (cons first res)) 11 | (appendo rest l2 res))])) 12 | 13 | (run* (l1 l2) 14 | (appendo l1 l2 (list 1 2 3 4))) -------------------------------------------------------------------------------- /demos/wg211/6-example-with-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module def racket 4 | (require "mk.rkt" #;"mk-with-check.rkt") 5 | (provide appendo) 6 | 7 | (defrel (appendo l1 l2 l3) 8 | (conde 9 | [(== l1 '()) (== l2 l3)] 10 | [(fresh (first rest res) 11 | (== l1 (cons first rest)) 12 | (== l3 (cons first res)) 13 | (appendo rest l2 res))]))) 14 | 15 | (module use racket 16 | (require "mk.rkt" #;"mk-with-check.rkt" 17 | (submod ".." def)) 18 | 19 | (run* (l1 l2) 20 | ;; What if I make an arity mistake? 21 | (appendo l1 l2 (list 1 2 3 4)))) 22 | 23 | (require 'use) -------------------------------------------------------------------------------- /demos/wg211/compile-with-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-defrel compile-run 4 | (for-syntax record-relation-arity!)) 5 | 6 | (require 7 | "runtime.rkt" 8 | syntax-spec 9 | (for-syntax syntax/parse 10 | (only-in ee-lib compiled-from))) 11 | 12 | ;; New 13 | (begin-for-syntax 14 | (define-persistent-symbol-table relation-arity) 15 | 16 | (define (record-relation-arity! relname arity) 17 | (symbol-table-set! 18 | relation-arity relname arity))) 19 | 20 | 21 | (define-syntax compile-defrel 22 | (syntax-parser 23 | [(_ name (x ...) g) 24 | #'(lambda (x ...) 25 | (lambda (s) 26 | (lambda () 27 | (#%app (compile-goal g) s))))])) 28 | 29 | (define-syntax compile-run 30 | (syntax-parser 31 | [(_ n (q) g) 32 | #'(let ([q (var 'q)]) 33 | (map (reify q) 34 | (run-goal n (compile-goal g))))])) 35 | 36 | (define-syntax compile-goal 37 | (syntax-parser 38 | #:datum-literals (succeed fail == disj2 conj2 fresh1) 39 | [(_ succeed) 40 | #'succeed-rt] 41 | [(_ fail) 42 | #'fail-rt] 43 | [(_ (== t1 t2)) 44 | #`(==-rt (compile-term t1) (compile-term t2))] 45 | [(_ (disj2 g1 g2)) 46 | #`(disj2-rt (compile-goal g1) (compile-goal g2))] 47 | [(_ (conj2 g1 g2)) 48 | #`(conj2-rt (compile-goal g1) (compile-goal g2))] 49 | [(_ (fresh1 (x) b)) 50 | #`(call/fresh 'x (lambda (x) (compile-goal b)))] 51 | [(_ (relname t ...)) 52 | (define actual (length (attribute t))) 53 | (define expected 54 | (symbol-table-ref relation-arity #'relname)) 55 | 56 | (when (not (= actual expected )) 57 | (raise-syntax-error 58 | #f 59 | (format "wrong number of arguments to relation; actual ~a, expected ~a" actual expected) 60 | (compiled-from #'relname))) 61 | 62 | #'(relname (compile-term t) ...)])) 63 | 64 | (define-syntax compile-term 65 | (syntax-parser 66 | #:datum-literals (quote cons) 67 | [(_ n:number) 68 | #''n] 69 | [(_ x:id) 70 | #'x] 71 | [(_ (quote t)) 72 | #''t] 73 | [(_ (cons t1 t2)) 74 | #`(cons (compile-term t1) (compile-term t2))])) -------------------------------------------------------------------------------- /demos/wg211/compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-defrel compile-run) 4 | 5 | (require 6 | "runtime.rkt" 7 | syntax-spec 8 | (for-syntax syntax/parse)) 9 | 10 | (define-syntax compile-defrel 11 | (syntax-parser 12 | [(_ name (x ...) g) 13 | #'(lambda (x ...) 14 | (lambda (s) 15 | (lambda () 16 | (#%app (compile-goal g) s))))])) 17 | 18 | (define-syntax compile-run 19 | (syntax-parser 20 | [(_ n (q) g) 21 | #'(let ([q (var 'q)]) 22 | (map (reify q) 23 | (run-goal n (compile-goal g))))])) 24 | 25 | (define-syntax compile-goal 26 | (syntax-parser 27 | #:datum-literals (succeed fail == disj2 conj2 fresh1) 28 | [(_ succeed) 29 | #'succeed-rt] 30 | [(_ fail) 31 | #'fail-rt] 32 | [(_ (== t1 t2)) 33 | #`(==-rt (compile-term t1) (compile-term t2))] 34 | [(_ (disj2 g1 g2)) 35 | #`(disj2-rt (compile-goal g1) (compile-goal g2))] 36 | [(_ (conj2 g1 g2)) 37 | #`(conj2-rt (compile-goal g1) (compile-goal g2))] 38 | [(_ (fresh1 (x) b)) 39 | #`(call/fresh 'x (lambda (x) (compile-goal b)))] 40 | [(_ (relname t ...)) 41 | #'(relname (compile-term t) ...)])) 42 | 43 | (define-syntax compile-term 44 | (syntax-parser 45 | #:datum-literals (quote cons) 46 | [(_ n:number) 47 | #''n] 48 | [(_ x:id) 49 | #'x] 50 | [(_ (quote t)) 51 | #''t] 52 | [(_ (cons t1 t2)) 53 | #`(cons (compile-term t1) (compile-term t2))])) -------------------------------------------------------------------------------- /demos/wg211/complete.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | "compile-with-check.rkt" 7 | (for-syntax syntax/parse)) 8 | 9 | ;; 10 | ;; Core syntax 11 | ;; 12 | 13 | (syntax-spec 14 | (binding-class term-variable) 15 | (binding-class relation-name) 16 | 17 | (extension-class term-macro) 18 | (extension-class goal-macro) 19 | 20 | (nonterminal term 21 | #:allow-extension term-macro 22 | 23 | n:number 24 | x:term-variable 25 | ((~literal quote) ()) 26 | ((~literal cons) t1:term t2:term)) 27 | 28 | (nonterminal goal 29 | #:description "miniKanren goal" 30 | #:allow-extension goal-macro 31 | 32 | succeed 33 | fail 34 | 35 | (== t1:term t2:term) 36 | 37 | (disj2 g1:goal g2:goal) 38 | (conj2 g1:goal g2:goal) 39 | 40 | (fresh1 (x:term-variable) b:goal) 41 | #:binding (scope (bind x) b) 42 | 43 | (r:relation-name t:term ...+))) 44 | 45 | 46 | ;; 47 | ;; Interface macros 48 | ;; 49 | 50 | (syntax-spec 51 | (host-interface/definition 52 | (core-defrel (name:relation-name x:term-variable ...) g:goal) 53 | #:binding [(export name) (scope (bind x) g)] 54 | 55 | #:lhs 56 | [(record-relation-arity! #'name (length (attribute x))) 57 | #'name] 58 | 59 | #:rhs 60 | [#'(compile-defrel (x ...) g)]) 61 | 62 | (host-interface/expression 63 | (core-run n:expr q:term-variable g:goal) 64 | #:binding (scope (bind q) g) 65 | #'(compile-run n q g))) 66 | 67 | 68 | ;; 69 | ;; Surface syntax 70 | ;; 71 | 72 | (define-syntax list 73 | (term-macro 74 | (syntax-rules () 75 | [(list) '()] 76 | [(list a rest ...) (cons a (list rest ...))]))) 77 | 78 | (define-syntax disj 79 | (goal-macro 80 | (syntax-rules () 81 | ((disj) fail) 82 | ((disj g) g) 83 | ((disj g0 g ...) (disj2 g0 (disj g ...)))))) 84 | 85 | (define-syntax conj 86 | (goal-macro 87 | (syntax-rules () 88 | ((conj) succeed) 89 | ((conj g) g) 90 | ((conj g0 g ...) (conj2 g0 (conj g ...)))))) 91 | 92 | (define-syntax fresh 93 | (goal-macro 94 | (syntax-rules () 95 | ((fresh () g ...) (conj g ...)) 96 | ((fresh (x0 x ...) g ...) 97 | (fresh1 (x0) 98 | (fresh (x ...) 99 | g ...)))))) 100 | 101 | (define-syntax conde 102 | (goal-macro 103 | (syntax-rules () 104 | ((conde (g ...) ...) 105 | (disj (conj g ...) ...))))) 106 | 107 | 108 | ;; 109 | ;; Surface syntax for interface macros 110 | ;; 111 | 112 | (define-syntax defrel 113 | (syntax-rules () 114 | [(defrel (name x ...) g ...) 115 | (core-defrel (name x ...) (conj g ...))])) 116 | 117 | (define-syntax run 118 | (syntax-rules () 119 | [(run n (x0 x ...) g ...) 120 | (run n q (fresh (x0 x ...) 121 | (== (list x0 x ...) q) g ...))] 122 | [(run n q g ...) 123 | (core-run n q (conj g ...))])) 124 | 125 | (define-syntax run* 126 | (syntax-rules () 127 | ((run* q g ...) (run #f q g ...)))) 128 | -------------------------------------------------------------------------------- /demos/wg211/mk-core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | (for-syntax syntax/parse)) 7 | 8 | ;; 9 | ;; Core syntax 10 | ;; 11 | 12 | (syntax-spec 13 | (nonterminal term 14 | n:number 15 | x:id 16 | ((~literal quote) ()) 17 | ((~literal cons) t1:term t2:term)) 18 | 19 | (nonterminal goal 20 | succeed 21 | fail 22 | 23 | (== t1:term t2:term) 24 | 25 | (disj2 g1:goal g2:goal) 26 | (conj2 g1:goal g2:goal) 27 | 28 | (fresh1 (x:id) b:goal) 29 | 30 | (r:id t:term ...+))) 31 | 32 | ;; 33 | ;; Interface macros 34 | ;; 35 | 36 | (syntax-spec 37 | (host-interface/definition 38 | (defrel (name:id x:id ...) 39 | g:goal) 40 | 41 | #:lhs [#'name] 42 | #:rhs [#''TODO]) 43 | 44 | (host-interface/expression 45 | (run n:racket-expr (q:id) g:goal) 46 | #''TODO)) 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /demos/wg211/mk-with-binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | (for-syntax syntax/parse)) 7 | 8 | ;; 9 | ;; Core syntax 10 | ;; 11 | 12 | (syntax-spec 13 | (binding-class term-variable) ;; New 14 | (binding-class relation-name) ;; New 15 | 16 | (nonterminal term 17 | n:number 18 | x:term-variable 19 | ((~literal quote) ()) 20 | ((~literal cons) t1:term t2:term)) 21 | 22 | (nonterminal goal 23 | succeed 24 | fail 25 | 26 | (== t1:term t2:term) 27 | 28 | (disj2 g1:goal g2:goal) 29 | (conj2 g1:goal g2:goal) 30 | 31 | (fresh1 (x:term-variable) b:goal) 32 | #:binding (scope (bind x) b) ;; New 33 | 34 | (r:relation-name t:term ...+))) 35 | 36 | 37 | ;; 38 | ;; Interface macros 39 | ;; 40 | 41 | (syntax-spec 42 | (host-interface/definition 43 | (defrel (name:relation-name x:term-variable ...) g:goal) 44 | #:binding [(export name) (scope (bind x) g)] ;; New 45 | 46 | #:lhs [#'name] 47 | #:rhs [#''TODO]) 48 | 49 | (host-interface/expression 50 | (run n:expr (q:term-variable) g:goal) 51 | #:binding (scope (bind q) g) ;; New 52 | #''TODO)) 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /demos/wg211/mk-with-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | "compile-with-check.rkt" ;; New 7 | (for-syntax syntax/parse)) 8 | 9 | ;; 10 | ;; Core syntax 11 | ;; 12 | 13 | (syntax-spec 14 | (binding-class term-variable) 15 | (binding-class relation-name) 16 | 17 | (extension-class term-macro) 18 | (extension-class goal-macro) 19 | 20 | (nonterminal term 21 | #:allow-extension term-macro 22 | 23 | n:number 24 | x:term-variable 25 | ((~literal quote) ()) 26 | ((~literal cons) t1:term t2:term)) 27 | 28 | (nonterminal goal 29 | #:allow-extension goal-macro 30 | 31 | succeed 32 | fail 33 | 34 | (== t1:term t2:term) 35 | 36 | (disj2 g1:goal g2:goal) 37 | (conj2 g1:goal g2:goal) 38 | 39 | (fresh1 (x:term-variable) b:goal) 40 | #:binding (scope (bind x) b) 41 | 42 | (r:relation-name t:term ...+))) 43 | 44 | 45 | ;; 46 | ;; Interface macros 47 | ;; 48 | 49 | (syntax-spec 50 | (host-interface/definition 51 | (core-defrel (name:relation-name 52 | x:term-variable ...) 53 | g:goal) 54 | #:binding [(export name) (scope (bind x) g)] 55 | 56 | #:lhs [(record-relation-arity! ;; New 57 | #'name 58 | (length (attribute x))) 59 | #'name] 60 | #:rhs [#'(compile-defrel name (x ...) g)]) 61 | 62 | (host-interface/expression 63 | (core-run n:expr (q:term-variable) g:goal) 64 | #:binding (scope (bind q) g) 65 | #'(compile-run n (q) g))) 66 | 67 | 68 | ;; 69 | ;; Surface syntax for terms 70 | ;; 71 | 72 | (define-dsl-syntax list term-macro 73 | (syntax-rules () 74 | [(list) '()] 75 | [(list a rest ...) 76 | (cons a (list rest ...))])) 77 | 78 | ;; 79 | ;; Surface syntax for goals 80 | ;; 81 | 82 | (define-dsl-syntax disj goal-macro 83 | (syntax-rules () 84 | ((disj) fail) 85 | ((disj g) g) 86 | ((disj g0 g ...) 87 | (disj2 g0 (disj g ...))))) 88 | 89 | (define-dsl-syntax conj goal-macro 90 | (syntax-rules () 91 | ((conj) succeed) 92 | ((conj g) g) 93 | ((conj g0 g ...) 94 | (conj2 g0 (conj g ...))))) 95 | 96 | (define-dsl-syntax fresh goal-macro 97 | (syntax-rules () 98 | ((fresh () g ...) (conj g ...)) 99 | ((fresh (x0 x ...) g ...) 100 | (fresh1 (x0) 101 | (fresh (x ...) 102 | g ...))))) 103 | 104 | (define-dsl-syntax conde goal-macro 105 | (syntax-rules () 106 | ((conde (g ...) ...) 107 | (disj (conj g ...) ...)))) 108 | 109 | 110 | ;; 111 | ;; Surface syntax for interface macros 112 | ;; 113 | 114 | (define-syntax defrel 115 | (syntax-rules () 116 | [(defrel (name x ...) g ...) 117 | (core-defrel (name x ...) (conj g ...))])) 118 | 119 | (define-syntax run 120 | (syntax-rules () 121 | [(run n (x0 x ...) g ...) 122 | (run n q (fresh (x0 x ...) 123 | (== (list x0 x ...) q) g ...))] 124 | [(run n q g ...) 125 | (core-run n (q) (conj g ...))])) 126 | 127 | (define-syntax run* 128 | (syntax-rules () 129 | ((run* q g ...) (run #f q g ...)))) 130 | -------------------------------------------------------------------------------- /demos/wg211/mk-with-sugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | (for-syntax syntax/parse)) 7 | 8 | ;; 9 | ;; Core syntax 10 | ;; 11 | 12 | (syntax-spec 13 | (binding-class term-variable) 14 | (binding-class relation-name) 15 | 16 | (extension-class term-macro) ;; New 17 | (extension-class goal-macro) ;; New 18 | 19 | (nonterminal term 20 | #:allow-extension term-macro ;; New 21 | 22 | n:number 23 | x:term-variable 24 | ((~literal quote) ()) 25 | ((~literal cons) t1:term t2:term)) 26 | 27 | (nonterminal goal 28 | #:allow-extension goal-macro ;; New 29 | 30 | succeed 31 | fail 32 | 33 | (== t1:term t2:term) 34 | 35 | (disj2 g1:goal g2:goal) 36 | (conj2 g1:goal g2:goal) 37 | 38 | (fresh1 (x:term-variable) b:goal) 39 | #:binding (scope (bind x) b) 40 | 41 | (r:relation-name t:term ...+))) 42 | 43 | 44 | ;; 45 | ;; Interface macros 46 | ;; 47 | 48 | (syntax-spec 49 | (host-interface/definition 50 | (core-defrel (name:relation-name 51 | x:term-variable ...) 52 | g:goal) 53 | #:binding [(export name) (scope (bind x) g)] 54 | 55 | #:lhs [#'name] 56 | #:rhs [#'(pretty-print '(defrel (name x ...) g))]) 57 | 58 | (host-interface/expression 59 | (core-run n:expr (q:term-variable) g:goal) 60 | #:binding (scope (bind q) g) 61 | #'(pretty-print '(run n (q) g)))) 62 | 63 | 64 | ;; 65 | ;; Surface syntax for terms 66 | ;; 67 | 68 | (define-dsl-syntax list term-macro 69 | (syntax-rules () 70 | [(list) '()] 71 | [(list a rest ...) 72 | (cons a (list rest ...))])) 73 | 74 | ;; 75 | ;; Surface syntax for goals 76 | ;; 77 | 78 | (define-dsl-syntax disj goal-macro 79 | (syntax-rules () 80 | ((disj) fail) 81 | ((disj g) g) 82 | ((disj g0 g ...) 83 | (disj2 g0 (disj g ...))))) 84 | 85 | (define-dsl-syntax conj goal-macro 86 | (syntax-rules () 87 | ((conj) succeed) 88 | ((conj g) g) 89 | ((conj g0 g ...) 90 | (conj2 g0 (conj g ...))))) 91 | 92 | (define-dsl-syntax fresh goal-macro 93 | (syntax-rules () 94 | ((fresh () g ...) (conj g ...)) 95 | ((fresh (x0 x ...) g ...) 96 | (fresh1 (x0) 97 | (fresh (x ...) 98 | g ...))))) 99 | 100 | (define-dsl-syntax conde goal-macro 101 | (syntax-rules () 102 | ((conde (g ...) ...) 103 | (disj (conj g ...) ...)))) 104 | 105 | 106 | ;; 107 | ;; Surface syntax for interface macros 108 | ;; 109 | 110 | (define-syntax defrel 111 | (syntax-rules () 112 | [(defrel (name x ...) g ...) 113 | (core-defrel (name x ...) (conj g ...))])) 114 | 115 | (define-syntax run ;; No binding rule, but hygienic. 116 | (syntax-rules () 117 | [(run n (x0 x ...) g ...) 118 | (run n q (fresh (x0 x ...) 119 | (== (list x0 x ...) q) g ...))] 120 | [(run n q g ...) 121 | (core-run n (q) (conj g ...))])) 122 | 123 | (define-syntax run* 124 | (syntax-rules () 125 | ((run* q g ...) (run #f q g ...)))) 126 | -------------------------------------------------------------------------------- /demos/wg211/mk.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require syntax-spec-dev 6 | "compile.rkt" ;; New 7 | (for-syntax syntax/parse)) 8 | 9 | ;; 10 | ;; Core syntax 11 | ;; 12 | 13 | (syntax-spec 14 | (binding-class term-variable) 15 | (binding-class relation-name) 16 | 17 | (extension-class term-macro) 18 | (extension-class goal-macro) 19 | 20 | (nonterminal term 21 | #:allow-extension term-macro 22 | 23 | n:number 24 | x:term-variable 25 | ((~literal quote) ()) 26 | ((~literal cons) t1:term t2:term)) 27 | 28 | (nonterminal goal 29 | #:allow-extension goal-macro 30 | 31 | succeed 32 | fail 33 | 34 | (== t1:term t2:term) 35 | 36 | (disj2 g1:goal g2:goal) 37 | (conj2 g1:goal g2:goal) 38 | 39 | (fresh1 (x:term-variable) b:goal) 40 | #:binding (scope (bind x) b) 41 | 42 | (r:relation-name t:term ...+))) 43 | 44 | 45 | ;; 46 | ;; Interface macros 47 | ;; 48 | 49 | (syntax-spec 50 | (host-interface/definition 51 | (core-defrel (name:relation-name 52 | x:term-variable ...) 53 | g:goal) 54 | #:binding [(export name) (scope (bind x) g)] 55 | 56 | #:lhs [#'name] 57 | #:rhs [#'(compile-defrel name (x ...) g)]) ;; New 58 | 59 | (host-interface/expression 60 | (core-run n:expr (q:term-variable) g:goal) 61 | #:binding (scope (bind q) g) 62 | #'(compile-run n (q) g))) ;; New 63 | 64 | 65 | ;; 66 | ;; Surface syntax for terms 67 | ;; 68 | 69 | (define-dsl-syntax list term-macro 70 | (syntax-rules () 71 | [(list) '()] 72 | [(list a rest ...) 73 | (cons a (list rest ...))])) 74 | 75 | ;; 76 | ;; Surface syntax for goals 77 | ;; 78 | 79 | (define-dsl-syntax disj goal-macro 80 | (syntax-rules () 81 | ((disj) fail) 82 | ((disj g) g) 83 | ((disj g0 g ...) 84 | (disj2 g0 (disj g ...))))) 85 | 86 | (define-dsl-syntax conj goal-macro 87 | (syntax-rules () 88 | ((conj) succeed) 89 | ((conj g) g) 90 | ((conj g0 g ...) 91 | (conj2 g0 (conj g ...))))) 92 | 93 | (define-dsl-syntax fresh goal-macro 94 | (syntax-rules () 95 | ((fresh () g ...) (conj g ...)) 96 | ((fresh (x0 x ...) g ...) 97 | (fresh1 (x0) 98 | (fresh (x ...) 99 | g ...))))) 100 | 101 | (define-dsl-syntax conde goal-macro 102 | (syntax-rules () 103 | ((conde (g ...) ...) 104 | (disj (conj g ...) ...)))) 105 | 106 | 107 | ;; 108 | ;; Surface syntax for interface macros 109 | ;; 110 | 111 | (define-syntax defrel 112 | (syntax-rules () 113 | [(defrel (name x ...) g ...) 114 | (core-defrel (name x ...) (conj g ...))])) 115 | 116 | (define-syntax run 117 | (syntax-rules () 118 | [(run n (x0 x ...) g ...) 119 | (run n q (fresh (x0 x ...) 120 | (== (list x0 x ...) q) g ...))] 121 | [(run n q g ...) 122 | (core-run n (q) (conj g ...))])) 123 | 124 | (define-syntax run* 125 | (syntax-rules () 126 | ((run* q g ...) (run #f q g ...)))) 127 | -------------------------------------------------------------------------------- /demos/zed-talk/macros.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; 4 | ;; Macros 5 | ;; 6 | 7 | 8 | (* (+ 1 2) 2) 9 | 10 | 11 | (define-syntax-rule 12 | (~> e1 (f arg ...) ...) 13 | ((apply compose 14 | (reverse 15 | (list 16 | (curryr f arg ...) 17 | ...))) 18 | e1)) 19 | 20 | 21 | (~> 1 22 | (+ 2) 23 | (* 2)) 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | ;; 42 | ;; Procedural macros 43 | ;; 44 | 45 | (require (for-syntax racket/base syntax/parse)) 46 | 47 | (define-syntax (match stx) 48 | (syntax-parse stx 49 | [(match e 50 | [pat rhs] 51 | ...) 52 | 53 | ;; Compile with arbitrary Racket code: 54 | ;; - Parse 55 | ;; - Check static semantics 56 | ;; - Optimize 57 | ;; - Generate code 58 | 59 | 'TODO])) 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /demos/zed-talk/micro-mk1.rkt: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; An example: 4 | 5 | (run* (q) 6 | (and 7 | (exists (x) 8 | (or 9 | (== q (cons 1 x)) 10 | (== q (cons 2 x)) 11 | (== q (cons 3 x)))) 12 | (exists (y) 13 | (or 14 | (== q (cons y 4)) 15 | (== q (cons y 5)))))) 16 | ;; => 17 | '((1 . 4) (1 . 5) 18 | (2 . 4) (2 . 5) 19 | (3 . 4) (3 . 5)) 20 | 21 | 22 | -------------------------------------------------------------------------------- /demos/zed-talk/micro-mk2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | #;(run* (q) 4 | (and 5 | (exists (x) 6 | (or 7 | (== q (cons 1 x)) 8 | (== q (cons 2 x)) 9 | (== q (cons 3 x)))) 10 | (exists (y) 11 | (or 12 | (== q (cons y 4)) 13 | (== q (cons y 5)))))) 14 | ;; => 15 | #;'((1 . 4) (1 . 5) 16 | (2 . 4) (2 . 5) 17 | (3 . 4) (3 . 5)) 18 | 19 | 20 | 21 | ;; Syntax definition 22 | 23 | (require "../../main.rkt") 24 | 25 | (syntax-spec 26 | (binding-class term-variable) 27 | 28 | (nonterminal goal 29 | (== t1:term t2:term) 30 | (and2 g1:goal g2:goal) 31 | (or2 g1:goal g2:goal) 32 | 33 | (exists (x:term-variable ...) b:goal)) 34 | 35 | (nonterminal term 36 | n:number 37 | x:term-variable 38 | (cons t1:term t2:term))) 39 | 40 | 41 | -------------------------------------------------------------------------------- /demos/zed-talk/micro-mk2b.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | #;(run* (q) 4 | (and 5 | (exists (x) 6 | (or 7 | (== q (cons 1 x)) 8 | (== q (cons 2 x)) 9 | (== q (cons 3 x)))) 10 | (exists (y) 11 | (or 12 | (== q (cons y 4)) 13 | (== q (cons y 5)))))) 14 | ;; => 15 | #;'((1 . 4) (1 . 5) 16 | (2 . 4) (2 . 5) 17 | (3 . 4) (3 . 5)) 18 | 19 | 20 | 21 | ;; Syntax definition 22 | 23 | (require "../../main.rkt") 24 | 25 | (syntax-spec 26 | (binding-class term-variable) 27 | 28 | (nonterminal goal 29 | (== t1:term t2:term) 30 | (and2 g1:goal g2:goal) 31 | (or2 g1:goal g2:goal) 32 | 33 | (exists (x:term-variable ...) b:goal) 34 | #:binding (scope (bind x) b)) 35 | 36 | (nonterminal term 37 | n:number 38 | x:term-variable 39 | (cons t1:term t2:term))) 40 | 41 | 42 | -------------------------------------------------------------------------------- /demos/zed-talk/tradeoffs.rkt: -------------------------------------------------------------------------------- 1 | 2 | 3 | Macros... 4 | 5 | - Integrate DSLs with a host 6 | - Don't need extra tools 7 | - Exist in industrial languages 8 | 9 | 10 | Workbenches... 11 | 12 | - Make language definition declarative with meta-DSLs 13 | 14 | 15 | 16 | How about both? -------------------------------------------------------------------------------- /demos/zed-talk/workbench.rkt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/michaelballantyne/syntax-spec/82687f30df3b2b364d4febcf9e40b06286ca4462/demos/zed-talk/workbench.rkt -------------------------------------------------------------------------------- /design/staged-minikanren.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out) 4 | quote cons 5 | (for-space mk quasiquote)) 6 | 7 | (require "../main.rkt" 8 | "../private/ee-lib/errors.rkt" 9 | (for-syntax 10 | racket/base 11 | syntax/parse 12 | syntax/id-table 13 | (except-in "../private/ee-lib/main.rkt" racket-var))) 14 | 15 | ;; 16 | ;; Core syntax 17 | ;; 18 | 19 | (syntax-spec 20 | (binding-class term-variable #:description "miniKanren term variable") 21 | (binding-class relation-name #:description "miniKanren relation name") 22 | 23 | (extension-class term-macro 24 | #:binding-space mk) 25 | (extension-class goal-macro 26 | #:binding-space mk) 27 | 28 | (nonterminal quoted 29 | #:description "quoted value" 30 | n:number 31 | s:id 32 | () 33 | (a:quoted . d:quoted)) 34 | 35 | (nonterminal term 36 | #:description "miniKanren term" 37 | #:allow-extension term-macro 38 | 39 | n:number 40 | x:term-variable 41 | ((~literal quote) t:quoted) 42 | ((~literal cons) t1:term t2:term)) 43 | 44 | (nonterminal goal 45 | #:description "miniKanren goal" 46 | #:allow-extension goal-macro 47 | 48 | succeed 49 | fail 50 | 51 | (== t1:term t2:term) 52 | 53 | (conj2 g1:goal g2:goal) 54 | 55 | (fresh1 (x:term-variable) b:goal) 56 | #:binding (scope (bind x) b) 57 | 58 | ; new reified call datatype 59 | (reify-call ) 60 | (apply-reified ) 61 | 62 | ; core staging extension 63 | (later g:goal) 64 | (now g:goal) 65 | 66 | (r:relation-name t:term ...+)) 67 | 68 | (nonterminal staged-goal 69 | #:description "miniKanren goal" 70 | #:allow-extension goal-macro 71 | 72 | succeed 73 | fail 74 | 75 | (== t1:term t2:term) 76 | 77 | (condg 78 | fallback-goal:dynamic-goal 79 | staged-condg-clause ...) 80 | 81 | (conj2 g1:goal g2:goal) 82 | 83 | (fresh1 (x:term-variable) b:goal) 84 | #:binding (scope (bind x) b) 85 | 86 | ; new reified call datatype 87 | (lreify-call ) 88 | (reify-call ) 89 | (apply-reified ) 90 | 91 | (l== t1:term t2:term) ; need equivalents for other constraints 92 | (ldisj g1:goal g2:goal) 93 | (lapp r:relation-name t:term ...+) 94 | 95 | ; do we really want specialized macros like all these? or should the 96 | ; staging-goals be more like surface goals. 97 | 98 | (r:relation-name t:term ...+)) 99 | 100 | (nonterminal condg-clause 101 | ([x:term-variable ...] [guard:goal] [body:goal]) 102 | #:binding (scope (bind x) guard body)) 103 | 104 | (host-interface/definition 105 | (defrel/condg (r:relation-name arg:term-variable ...) 106 | clause:condg-clause ...) 107 | #:binding [(export r) (scope (bind arg) clause)] 108 | 109 | #:lhs [#'r] 110 | #:rhs [#'(void)])) 111 | 112 | 113 | -------------------------------------------------------------------------------- /design/statechart-examples/statechart-counter.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart machine 4 | (context count 0) 5 | 6 | (event increment) 7 | 8 | (state active 9 | (on increment 10 | (set count (+ count 1))))) 11 | 12 | 13 | (send-event machine increment) -------------------------------------------------------------------------------- /design/statechart-examples/statechart-flight-booker.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart flight-kind 4 | (data start-date #f) 5 | (data return-date #f) 6 | (data trip 'one-way) 7 | 8 | (state editing 9 | (on (start-widget.update val) 10 | (set start-date val)) 11 | (on (return-widget.update val) 12 | (set return-date val)) 13 | (on (set-trip val) 14 | (set trip val)) 15 | 16 | (on (submit) 17 | (when (if (eq? trip 'one-way) 18 | start-date 19 | (and start-date 20 | return-date 21 | (date> return-date start-date)))) 22 | (-> submitted))) 23 | 24 | (state submitted 25 | (final))) 26 | -------------------------------------------------------------------------------- /design/statechart-examples/statechart-reddit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart reddit-browser 4 | (data subreddit #f) 5 | (data posts 6 | 7 | (state idle) 8 | (state selected 9 | (state loading 10 | (invoke fetch-subreddit 11 | (on (done val) 12 | (set posts val) 13 | (-> loaded)) 14 | (on error (-> failed)))) 15 | (state loaded) 16 | (state failed)) 17 | 18 | (on (select val) 19 | (set subreddit val) 20 | (-> selected))) -------------------------------------------------------------------------------- /design/statechart-examples/statechart-temp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart temp 4 | (data C #f) 5 | (data F #f) 6 | 7 | (state active 8 | (on (celcius val) 9 | (set C val) 10 | (set F (+ (* val (/ 9 5)) 32)) 11 | (on (farenheit val) 12 | (set C (* (- val 32) (/ 5 9))) 13 | (set F val))))) -------------------------------------------------------------------------------- /design/statechart-examples/statechart-timer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart timer 4 | (data elapsed 0) 5 | (data duration 5) 6 | (data interval 0.1) 7 | 8 | (state running 9 | (invoke 10 | (lambda (cb) 11 | (define i (set-interval (lambda () (cb tick)))) 12 | (lambda () 13 | (clear-interval i)))) 14 | 15 | (on eps 16 | (when elapsed >= duration) 17 | (-> paused)) 18 | 19 | (on (tick) 20 | (action 21 | (set elapsed (+ elapsed interval))))) 22 | 23 | (state paused 24 | (on eps 25 | (cond (< elapsed duration)) 26 | (-> running))) 27 | 28 | (on (duration.update val) 29 | (set duration val)) 30 | 31 | (on (reset) 32 | (set elapsed 0))) -------------------------------------------------------------------------------- /design/statechart-examples/statechart-trafficlight.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart walk-light 4 | (initial walk) 5 | (state walk 6 | (on walk-timer (-> countdown))) 7 | (state countdown 8 | (on countdown-timer (-> stop))) 9 | (state stop)) 10 | 11 | (define-statechart stop-light 12 | (state green 13 | (on green-timer (-> yellow)) 14 | (use walk-light #:as ped)) 15 | (state yellow 16 | (on yellow-timer (-> red))) 17 | (state red 18 | (on red-timer (-> green)))) 19 | -------------------------------------------------------------------------------- /design/statechart-examples/statechart-watch.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define-statechart watch 4 | (state dislays 5 | (state time 6 | (on button-d (-> date)) 7 | (on button-a (-> alarm1))) 8 | (state date 9 | (on button-d (-> time)) 10 | (timeout (minutes 2) (-> time))) 11 | (state alarm1 12 | (init disabled #:history) 13 | (state disabled) 14 | (state enabled) 15 | (on button-a (-> alarm2))) 16 | (state alarm2 17 | (init disabled #:history) 18 | (state disabled) 19 | (state enabled) 20 | (on button-a (-> chime))) 21 | (state chime 22 | (on button-a (-> stopwatch))) 23 | (state stopwatch 24 | (on button-a (-> time)))) 25 | 26 | (state alarms 27 | (state alarm1) 28 | (state alarm2) 29 | (state both-alarms) 30 | 31 | (on button 32 | (-> displays))) -------------------------------------------------------------------------------- /design/statechart-examples/statecharts-login.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ; Very much not complete... 4 | 5 | (define-statechart submitready 6 | (state missing-input) 7 | (state ready)) 8 | 9 | (define-statechart authenticate 10 | (state connecting) 11 | (state connected)) 12 | 13 | (define-statechart session 14 | (data time) 15 | 16 | (state connected) 17 | (state disconnected)) 18 | 19 | (define-statechart login 20 | (parallel 21 | submitready 22 | authenticate)) 23 | 24 | (define-statechart login-with-freeze 25 | (data attempts 0) 26 | 27 | (state can-login 28 | login) 29 | (state frozen)) 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /design/statecharts-full.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../main.rkt" (for-syntax syntax/parse)) 4 | 5 | (syntax-spec 6 | (binding-class statechart-name) 7 | (binding-class state-name) 8 | (binding-class var) 9 | (binding-class data-name) 10 | 11 | (nonterminal/exporting state-body 12 | (initial n:state-name) 13 | #:binding (scope n) 14 | 15 | e:event 16 | 17 | (data n:data-name e:racket-expr) 18 | #:binding (export n) 19 | 20 | (state n:state-name 21 | sb:state-body ...) 22 | #:binding [(export n) (scope (import sb) ...)] 23 | 24 | (use scn:statechart-name #:as sn:state-name 25 | e:event ...)) 26 | 27 | (nonterminal event 28 | (on (evt:id arg:var ...) 29 | ab:action ...+) 30 | #:binding (scope (bind arg) ... ab ...) 31 | 32 | (on-enter ab:action ...) 33 | (on-exit ab:action ...)) 34 | 35 | (nonterminal action 36 | (-> s:state-name) 37 | 38 | (set n:data-name e:racket-expr) 39 | 40 | (emit (name:id arg:racket-expr ...)) 41 | 42 | (let* (b:binding-group ...) body:action ...) 43 | #:binding (nest b ... [body ...])) 44 | 45 | (nonterminal/nesting binding-group (tail) 46 | [v:var e:racket-expr] 47 | #:binding (scope (bind v) tail)) 48 | 49 | #;(host-interface/definition 50 | (define-statechart n:statechart-name 51 | sb:state-body) 52 | #:binding [(export n) (scope (import sb))]) 53 | 54 | (host-interface/expression 55 | (machine st:statechart-name) 56 | #''TODO)) 57 | 58 | ; (machine, any) -> (machine, (listof any)) 59 | (define (machine-step m event) 60 | 'TODO) 61 | 62 | ; ... accessors ... 63 | -------------------------------------------------------------------------------- /design/statecharts-smaller.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../main.rkt" (for-syntax syntax/parse)) 4 | 5 | (syntax-spec 6 | (binding-class statechart-name) 7 | (binding-class state-name) 8 | (binding-class var) 9 | (binding-class data-name) 10 | 11 | (nonterminal/exporting state-body 12 | (initial n:state-name) 13 | #:binding (scope n) 14 | 15 | e:event 16 | 17 | (state n:state-name 18 | sb:state-body ...) 19 | #:binding [(export n) (scope (import sb) ...)] 20 | 21 | (use scn:statechart-name #:as sn:state-name 22 | e:event ...)) 23 | 24 | (nonterminal event 25 | (on (evt:id arg:var ...) 26 | ab:action ...+) 27 | #:binding (scope (bind arg) ... ab)) 28 | 29 | (nonterminal action 30 | (-> s:state-name) 31 | 32 | (set n:data-name e:racket-expr) 33 | 34 | (emit (name:id arg:racket-expr ...)) 35 | 36 | (let* (b:binding-group ...) body:action ...) 37 | #:binding (nest b ... body)) 38 | 39 | (nonterminal/nesting binding-group (tail) 40 | [v:var e:racket-expr] 41 | #:binding (scope (bind v) tail)) 42 | 43 | #;(host-interface/definition 44 | (define-statechart n:statechart-name 45 | sb:state-body) 46 | #:binding [(export n) (scope (import sb))]) 47 | 48 | (host-interface/expression 49 | (machine st:statechart-name) 50 | #''TODO)) 51 | 52 | ; (machine, any) -> (machine, (listof any)) 53 | (define (machine-step m event) 54 | 'TODO) 55 | 56 | ; ... accessors ... 57 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define name "syntax-spec-dev") 4 | (define collection "syntax-spec-dev") 5 | (define version "0.1") 6 | (define license '(Apache-2.0 OR MIT)) 7 | (define deps '("base" 8 | "version-case" 9 | "syntax-classes-lib" 10 | "rackunit-lib")) 11 | (define build-deps '("racket-doc" "scribble-lib" "drracket" "typed-racket-lib")) 12 | (define scribblings '(("scribblings/main.scrbl" (multi-page) (experimental) "syntax-spec-dev"))) 13 | (define compile-omit-paths '("design" "demos")) 14 | (define test-omit-paths '("design" "demos")) 15 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-from-out "private/syntax/interface.rkt") 4 | (for-syntax 5 | number 6 | id 7 | ... 8 | ...+ 9 | 10 | mutable-reference-compiler 11 | immutable-reference-compiler 12 | 13 | make-variable-like-reference-compiler 14 | 15 | symbol-table? 16 | mutable-symbol-table? 17 | define-persistent-symbol-table 18 | ; deprecated 19 | define-local-symbol-table 20 | local-symbol-table 21 | 22 | symbol-table-set! 23 | symbol-table-ref 24 | symbol-table-has-key? 25 | 26 | symbol-set? 27 | mutable-symbol-set? 28 | define-persistent-symbol-set 29 | local-symbol-set 30 | 31 | symbol-set-add! 32 | symbol-set-member? 33 | 34 | immutable-symbol-table? 35 | immutable-symbol-table 36 | 37 | symbol-table-set 38 | symbol-table-remove 39 | 40 | immutable-symbol-set? 41 | immutable-symbol-set 42 | 43 | symbol-set-add 44 | symbol-set-remove 45 | symbol-set-union 46 | symbol-set-intersect 47 | symbol-set-subtract 48 | 49 | in-symbol-table 50 | in-symbol-set 51 | 52 | compiled-identifier=? 53 | free-identifiers 54 | binding-identifiers 55 | alpha-equivalent? 56 | get-racket-referenced-identifiers)) 57 | 58 | (require "private/syntax/interface.rkt" 59 | "private/runtime/compile.rkt" 60 | (for-syntax syntax/parse 61 | (except-in "private/ee-lib/main.rkt" racket-var) 62 | "private/ee-lib/persistent-id-table.rkt" 63 | "private/ee-lib/binding.rkt" 64 | "private/runtime/binding-operations.rkt" 65 | "private/runtime/syntax-classes.rkt")) 66 | -------------------------------------------------------------------------------- /private/ee-lib/binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide identifier-has-binding? 4 | identifier-with-binding? 5 | same-binding? 6 | top-binding? 7 | module-or-top-binding? 8 | maybe-raise-ambiguity-error) 9 | 10 | (require racket/private/check 11 | "flip-intro-scope.rkt") 12 | 13 | (define/who (identifier-has-binding? id) 14 | (check who identifier? id) 15 | 16 | (not (not (identifier-binding id (syntax-local-phase-level) #t)))) 17 | 18 | (define (identifier-with-binding? val) 19 | (and (identifier? val) (identifier-has-binding? val))) 20 | 21 | (define/who (same-binding? id1 id2) 22 | (check who identifier? id1) 23 | (check who identifier? id2) 24 | 25 | (maybe-raise-ambiguity-error id1) 26 | (maybe-raise-ambiguity-error id2) 27 | 28 | (let ([id1-ext (if (syntax-transforming?) (flip-intro-scope id1) id1)] 29 | [id2-ext (if (syntax-transforming?) (flip-intro-scope id2) id2)]) 30 | 31 | (and (identifier-has-binding? id1-ext) 32 | (identifier-has-binding? id2-ext) 33 | (free-identifier=? id1-ext id2-ext)))) 34 | 35 | (define/who (top-binding? id) 36 | (check who identifier-with-binding? id) 37 | 38 | (define binding 39 | (identifier-binding id (syntax-local-phase-level) #t)) 40 | 41 | (and (list? binding) (= 1 (length binding)))) 42 | 43 | (define/who (module-or-top-binding? id) 44 | (check who identifier-with-binding? id) 45 | 46 | (define binding 47 | (identifier-binding id (syntax-local-phase-level) #t)) 48 | (list? binding)) 49 | 50 | ;; situation ; identifier-binding ; syntax-local-value ; syntax-debug-info 51 | ;; bound as syntax ; non-#f value ; environment value ; has matching binding(s) 52 | 53 | ;; note: the following two cases can't be easily distinguished; this is why `lookup` 54 | ;; never tells you a name is unbound or out-of-context, and instead can only tell you 55 | ;; that it isn't bound to the particular kind of syntax you check via the predicate. 56 | ;; bound as racket ; non-#f value ; fails ; has matching binding(s) 57 | ;; out of context ; non-#f value ; fails ; has matching binding(s) 58 | 59 | ;; unbound ; #f ; fails ; no matching bindings (I hope!) 60 | ;; ambiguous ; #f ; fails ; has matching binding(s) 61 | (define (maybe-raise-ambiguity-error id) 62 | (define (has-matching-bindings? id) 63 | (define debug-info (syntax-debug-info (if (syntax-transforming?) (flip-intro-scope id) id))) 64 | (and 65 | (hash-has-key? debug-info 'bindings) 66 | (let* ([bindings (hash-ref debug-info 'bindings)] 67 | [matching-bindings (filter (lambda (b) (hash-ref b 'match?)) bindings)]) 68 | (not (null? matching-bindings))))) 69 | 70 | (when (and (not (identifier-binding id (syntax-local-phase-level) #t)) 71 | (has-matching-bindings? id)) 72 | ;; have racket raise the error by local-expanding 73 | (if (syntax-transforming?) 74 | (local-expand id 'expression '()) 75 | (error 'maybe-raise-ambiguity-error "internal error: don't know how to raise ambiguity error")))) -------------------------------------------------------------------------------- /private/ee-lib/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax 5 | racket/base 6 | (rename-in syntax/parse [define/syntax-parse def/stx]) 7 | racket/syntax 8 | racket/generic 9 | "main.rkt" 10 | "syntax-category.rkt")) 11 | 12 | (provide 13 | define-literal-forms 14 | define-extensible-syntax) 15 | 16 | (begin-for-syntax 17 | (define-syntax-class symbol 18 | (pattern stx:id 19 | #:attr sym (syntax-e (attribute stx)))) 20 | (struct literal-rep [msg] 21 | #:property prop:procedure (lambda (s stx) (raise-syntax-error #f (literal-rep-msg s) stx)) 22 | #:property prop:not-racket-syntax #t)) 23 | 24 | (define-syntax define-literal-forms 25 | (module-macro 26 | (syntax-parser 27 | [(_ literal-set-name:id 28 | (~optional (~seq #:syntax-class syntax-class-name:id)) 29 | (~optional (~seq #:binding-space (~or space:symbol #f))) 30 | msg:string (name:id ...)) 31 | #:with (spaced-name ...) (map (in-space (attribute space.sym)) (attribute name)) 32 | #'(begin 33 | (define-syntax spaced-name (literal-rep 'msg)) 34 | ... 35 | (begin-for-syntax 36 | (define-literal-set literal-set-name 37 | (spaced-name ...)) 38 | (~? (define-syntax-class syntax-class-name 39 | #:literal-sets (literal-set-name) 40 | (pattern (~or spaced-name ...))) 41 | (begin))))]))) 42 | 43 | (require (for-syntax syntax/parse/private/sc)) 44 | 45 | (begin-for-syntax 46 | (define (make-extension-definition-transformer rep-constructor) 47 | (syntax-parser 48 | [(_ name:id rhs) 49 | #`(define-syntax name (#,rep-constructor rhs))])) 50 | 51 | (define-syntax-class head 52 | (pattern (name:id . rest) 53 | #:attr pat #'((~var name id) . rest)) 54 | (pattern name:id 55 | #:attr pat #'(~var name id))) 56 | 57 | (define (make-simple-macro-definition-transformer define-form) 58 | (syntax-parser 59 | [(_ h:head . body) 60 | #`(#,define-form h.name 61 | (syntax-parser/template 62 | #,((make-syntax-introducer) this-syntax) 63 | [h.pat . body]))]))) 64 | 65 | (define-syntax define-extensible-syntax 66 | (module-macro 67 | (syntax-parser 68 | [(_ name) 69 | (def/stx gen-name (format-id #'name "gen:~a" #'name)) 70 | (def/stx name-transform (format-id #'name "~a-transform" #'name)) 71 | (def/stx name-rep (format-id #'name "~a-rep" #'name)) 72 | (def/stx name-rep-procedure (format-id #'name "~a-rep-procedure" #'name)) 73 | (def/stx define-name (format-id #'name "define-~a" #'name)) 74 | (def/stx define-simple-name (format-id #'name "define-simple-~a" #'name)) 75 | #'(begin 76 | (begin-for-syntax 77 | (define-generics name 78 | (name-transform name stx)) 79 | (struct name-rep (procedure) 80 | #:methods gen-name 81 | [(define (name-transform s stx) 82 | ((name-rep-procedure s) stx))])) 83 | (define-syntax define-name (make-extension-definition-transformer #'name-rep)) 84 | (define-syntax define-simple-name 85 | (make-simple-macro-definition-transformer #'define-name)))]))) 86 | -------------------------------------------------------------------------------- /private/ee-lib/errors.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide raise-argument-error/stx (struct-out exn:fail:contract:srcloc)) 4 | 5 | (define-struct (exn:fail:contract:srcloc 6 | exn:fail:contract) 7 | (srcloc) 8 | #:property prop:exn:srclocs 9 | (lambda (s) 10 | (list (exn:fail:contract:srcloc-srcloc s)))) 11 | 12 | (define (syntax->srcloc blame-stx) 13 | (srcloc 14 | (syntax-source blame-stx) 15 | (syntax-line blame-stx) 16 | (syntax-column blame-stx) 17 | (syntax-position blame-stx) 18 | (syntax-span blame-stx))) 19 | 20 | (define (raise-argument-error/stx name expected v stx) 21 | (raise (exn:fail:contract:srcloc 22 | (format "~a: ~a: contract violation\n expected: ~a\n given: ~a" 23 | (srcloc->string (syntax->srcloc stx)) 24 | name 25 | expected 26 | v) 27 | (current-continuation-marks) 28 | (syntax->srcloc stx)))) 29 | 30 | 31 | -------------------------------------------------------------------------------- /private/ee-lib/flip-intro-scope.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide flip-intro-scope) 4 | 5 | (require racket/private/check) 6 | 7 | (define (make-intro-scope-introducer) 8 | (define no-scope (datum->syntax #f 'foo)) 9 | (define intro-scope 10 | (syntax-local-identifier-as-binding 11 | (syntax-local-introduce 12 | no-scope))) 13 | (make-syntax-delta-introducer 14 | intro-scope 15 | no-scope)) 16 | 17 | (define/who (flip-intro-scope stx) 18 | (check who syntax? stx) 19 | ((make-intro-scope-introducer) stx 'flip)) 20 | -------------------------------------------------------------------------------- /private/ee-lib/lift-disappeareds.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base racket/list "flip-intro-scope.rkt")) 4 | 5 | (provide 6 | (for-syntax 7 | lift-from-properties! 8 | lift-disappeared-uses! 9 | lift-disappeared-bindings!)) 10 | 11 | (begin-for-syntax 12 | (define lifted? #f) 13 | (define lifted-properties (make-hasheq)) 14 | 15 | (define (ensure-module-end!) 16 | (when (not lifted?) 17 | (syntax-local-lift-expression #'(emit-lifteds))) 18 | (set! lifted? #t)) 19 | 20 | ; Lift properties conveying information to the IDE from stx. Return stx without these props. 21 | (define (lift-from-properties! stx) 22 | (for/fold ([stx stx]) 23 | ([prop-key '(disappeared-use disappeared-binding sub-range-binders mouse-over-tooltips)]) 24 | (cond 25 | [(syntax-property stx prop-key) 26 | (lift-property! prop-key (syntax-property stx prop-key)) 27 | (syntax-property-remove stx prop-key)] 28 | [else stx]))) 29 | 30 | (define (lift-property! prop-key prop-val) 31 | (ensure-module-end!) 32 | (hash-update! lifted-properties prop-key (lambda (old-val) (cons prop-val old-val)) '())) 33 | 34 | (define (lift-disappeared-uses! . ids) 35 | (lift-property! 'disappeared-use (map flip-intro-scope ids))) 36 | 37 | (define (lift-disappeared-bindings! . ids) 38 | (lift-property! 'disappeared-binding (map flip-intro-scope ids)))) 39 | 40 | (define-syntax (emit-lifteds stx) 41 | (define result 42 | (for/fold ([result #'(void)]) 43 | ([(prop-key prop-val) (in-hash lifted-properties)]) 44 | (syntax-property result prop-key (flatten prop-val)))) 45 | ; Reset so another end declaration lift is triggered if macros 46 | ; that are themselves end declarations lift disappeareds. 47 | (set! lifted? #f) 48 | (set! lifted-properties (make-hasheq)) 49 | 50 | result) 51 | -------------------------------------------------------------------------------- /private/ee-lib/lift-trampoline.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide wrap-lift-trampoline 4 | trampoline-lift! 5 | trampoline-lift-context?) 6 | 7 | (require racket/control 8 | racket/private/check) 9 | 10 | (module macro racket/base 11 | (require (for-syntax racket/base)) 12 | (provide continue-trampoline) 13 | (define-syntax (continue-trampoline stx) 14 | ((syntax-e (cadr (syntax->list stx)))))) 15 | 16 | (require (for-template racket/base 'macro)) 17 | 18 | (define lift-tag (make-continuation-prompt-tag)) 19 | 20 | (define/who (trampoline-lift! stx) 21 | (check who syntax? stx) 22 | 23 | (unless (trampoline-lift-context?) 24 | (error who "not in trampoline lift context")) 25 | 26 | (control-at 27 | lift-tag k 28 | #`(begin #,stx 29 | (continue-trampoline 30 | #,(lambda () (prompt-at lift-tag (k))))))) 31 | 32 | (define (trampoline-lift-context?) 33 | (continuation-prompt-available? lift-tag)) 34 | 35 | (define/who (wrap-lift-trampoline transformer) 36 | (check who procedure? transformer) 37 | 38 | (lambda (stx) 39 | (prompt-at lift-tag (transformer stx)))) -------------------------------------------------------------------------------- /private/ee-lib/syntax-category.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide prop:not-racket-syntax 4 | not-racket-syntax?) 5 | 6 | ; Used to indicate that a value in the expander environment should not be used as racket syntax, 7 | ; even though it may be a procedure, implement prop:procedure, or implement prop:set!-transformer. 8 | ; In this case, the transformer is only used to raise a syntax error when used in a racket expression. 9 | (define-values 10 | (prop:not-racket-syntax not-racket-syntax? not-racket-syntax-ref) 11 | (make-struct-type-property 'not-racket-syntax)) 12 | -------------------------------------------------------------------------------- /private/ee-lib/syntax-datum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide syntax-datum?) 4 | 5 | (require racket/prefab) 6 | 7 | (define (syntax-datum? v) 8 | (or (null? v) 9 | (symbol? v) 10 | (boolean? v) 11 | (number? v) 12 | (string? v) 13 | (and (pair? v) (syntax-datum? (car v)) (syntax-datum? (cdr v))) 14 | (and (vector? v) (for/and ([el v]) (syntax-datum? el))) 15 | (and (box? v) (syntax-datum? (unbox v))) 16 | (and (hash? v) (for/and ([(k v) v]) (and (syntax-datum? k) (syntax-datum? v)))) 17 | (and (immutable-prefab-struct-key v) (for/and ([el (in-vector (struct->vector v) 1)]) 18 | (syntax-datum? el))))) -------------------------------------------------------------------------------- /private/ee-lib/test/same-binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | rackunit 5 | (for-syntax racket/base "../main.rkt")) 6 | 7 | (define-syntax (m stx) 8 | (define ctx (syntax-local-make-definition-context)) 9 | (define id^ (car (syntax-local-bind-syntaxes (list #'x) #'5 ctx))) 10 | #``([unbound/unbound #,(same-binding? #'x #'x)] 11 | [local/local #,(same-binding? id^ id^)] 12 | [unbound/local #,(same-binding? #'x id^)])) 13 | 14 | (check-equal? 15 | (m) 16 | '([unbound/unbound #f] 17 | [local/local #t] 18 | [unbound/local #f])) 19 | 20 | ; top level, unbound 21 | (check-equal? 22 | (eval '(begin 23 | (require "../main.rkt") 24 | (same-binding? #'x #'x)) 25 | (make-base-namespace)) 26 | #f) 27 | 28 | ; top level, bound 29 | (check-equal? 30 | (eval '(begin 31 | (require "../main.rkt") 32 | (define x 5) 33 | (same-binding? #'x #'x)) 34 | (make-base-namespace)) 35 | #t) -------------------------------------------------------------------------------- /private/runtime/errors.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide struct-error-as-expression 4 | dsl-error-as-expression) 5 | 6 | (define (struct-error-as-expression message) 7 | (lambda (s stx) 8 | (raise-syntax-error 9 | #f 10 | message 11 | stx))) 12 | 13 | (define (dsl-error-as-expression type) 14 | (struct-error-as-expression 15 | (string-append 16 | type 17 | " may not be used as a racket expression"))) -------------------------------------------------------------------------------- /private/runtime/syntax-classes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide literal-in-space 4 | ~space-literal) 5 | 6 | (require syntax/parse "../ee-lib/main.rkt" (for-template "../ee-lib/lift-disappeareds.rkt") 7 | (for-syntax racket/base syntax/parse)) 8 | 9 | (define-syntax-class (literal-in-space target-id binding-space) 10 | (pattern id:id 11 | #:when (same-binding? ((in-space binding-space) (attribute id)) 12 | ((in-space binding-space) target-id)) 13 | #:do [(lift-disappeared-uses! ((in-space binding-space) (attribute id)))])) 14 | 15 | (define-syntax ~space-literal 16 | (pattern-expander 17 | (syntax-parser 18 | [(_ target-id:id binding-space:id) 19 | #'(~var _ (literal-in-space #'target-id 'binding-space))]))) -------------------------------------------------------------------------------- /private/syntax/compile/pattern-var-reflection.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | ;; (rebind-pattern-vars (v ...) e b) 5 | ;; 6 | ;; Rebind the pattern variables `v ...` to the values returned by `e`, for use in `b`. 7 | ;; Pattern vars must be bound as syntax parse attributes, not just syntax-case pattern vars. 8 | 9 | ;; `e` must return a value for each pattern variable `v`, where the value has nested 10 | ;; list structure matching the depth associated with the pattern variable. 11 | rebind-pattern-vars) 12 | 13 | (require (for-syntax racket/base 14 | syntax/parse 15 | racket/syntax 16 | (only-in racket/private/sc 17 | make-syntax-mapping 18 | syntax-pattern-variable? 19 | syntax-mapping-depth 20 | syntax-mapping-valvar)) 21 | (only-in racket/private/template 22 | attribute-mapping 23 | attribute-mapping? 24 | attribute-mapping-name 25 | attribute-mapping-var 26 | attribute-mapping-depth 27 | attribute-mapping-check) 28 | (only-in syntax/parse/private/residual 29 | check-attr-value)) 30 | 31 | (define-syntax rebind-pattern-vars 32 | (syntax-parser 33 | [(_ (var ...) rhs body) 34 | #:with (new-val ...) (generate-temporaries #'(var ...)) 35 | #:with (attr-var ...) (generate-temporaries #'(var ...)) 36 | #:with (attr-mapping ...) (map reflect-attribute-mapping (attribute var) (attribute new-val)) 37 | #:with (stx-mapping ...) (map reflect-syntax-mapping (attribute var) (attribute attr-var)) 38 | 39 | #'(let-values ([(new-val ...) rhs]) 40 | (letrec-syntaxes+values ([(attr-var) attr-mapping] 41 | ...) () 42 | (letrec-syntaxes+values ([(var) stx-mapping] 43 | ...) () 44 | body)))])) 45 | 46 | (begin-for-syntax 47 | (define (reflect-attribute-mapping var new-var) 48 | (define stx-mapping (get-pvar-info var)) 49 | 50 | (define (unbound-error) (wrong-syntax var "expected pattern variable with attribute binding")) 51 | 52 | (let ([attr-mapping (syntax-local-value (syntax-mapping-valvar stx-mapping) unbound-error)]) 53 | #`(attribute-mapping 54 | (quote-syntax #,new-var) 55 | '#,(attribute-mapping-name attr-mapping) 56 | '#,(attribute-mapping-depth attr-mapping) 57 | ;; Have templates always check the contents of the rebinding 58 | (quote-syntax check-attr-value)))) 59 | 60 | (define (reflect-syntax-mapping var new-valvar) 61 | (define existing-mapping (get-pvar-info var)) 62 | #`(make-syntax-mapping 63 | '#,(syntax-mapping-depth existing-mapping) 64 | (quote-syntax #,new-valvar))) 65 | 66 | (define (get-pvar-info v) 67 | (define (unbound-error) (wrong-syntax v "expected pattern var")) 68 | (define binding (syntax-local-value v unbound-error)) 69 | (when (not (syntax-pattern-variable? binding)) 70 | (unbound-error)) 71 | binding)) 72 | 73 | -------------------------------------------------------------------------------- /private/syntax/env-reps.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (struct-out bindclass-rep) 4 | (struct-out extclass-rep) 5 | (struct-out nonterm-rep) 6 | 7 | (struct-out simple-nonterm-info) 8 | (struct-out nesting-nonterm-info) 9 | (struct-out exporting-nonterm-info) 10 | 11 | (struct-out nested-binding) 12 | (struct-out special-syntax-class-binding) 13 | (struct-out pvar-rep) 14 | 15 | stxclass-rep?) 16 | 17 | (require syntax/parse 18 | version-case 19 | "../runtime/errors.rkt" 20 | racket/syntax 21 | "../ee-lib/syntax-category.rkt" 22 | (for-syntax racket/base) 23 | (for-template racket/base)) 24 | 25 | (version-case 26 | [(version< (version) "8.10") 27 | (require (only-in syntax/parse/private/residual-ct stxclass? has-stxclass-prop?))] 28 | [else 29 | (require (only-in (submod syntax/parse/private/residual ct) stxclass? has-stxclass-prop?))]) 30 | 31 | (define (nonterm-lang-error-as-expression type) 32 | (struct-error-as-expression 33 | (string-append 34 | type 35 | " may only be referenced in nonterminal specifications"))) 36 | 37 | ;; When used as an expression, extension class names act as contructors 38 | ;; for macros belonging to the extension class. 39 | (define (expand-as-constructor s stx) 40 | (syntax-parse stx 41 | [(_ e) 42 | (with-syntax ([constr (extclass-rep-constr s)]) 43 | #'(constr e))] 44 | [_ 45 | (wrong-syntax stx "expected expression producing a macro transformer")])) 46 | 47 | #;(Any -> boolean?) 48 | ; Is the value an expander environment representative of a syntax class? 49 | ; Used to recognize something like e:expr 50 | (define (stxclass-rep? v) 51 | (or (stxclass? v) 52 | (has-stxclass-prop? v))) 53 | 54 | (struct bindclass-rep (description constr pred binding-space) 55 | #:property prop:procedure 56 | (nonterm-lang-error-as-expression "binding classes") 57 | #:property prop:not-racket-syntax #t) 58 | 59 | (struct extclass-rep (constr pred acc binding-space) 60 | #:property prop:procedure 61 | expand-as-constructor 62 | #:property prop:not-racket-syntax #t) 63 | 64 | (struct nonterm-rep (variant-info) 65 | #:property prop:procedure 66 | (nonterm-lang-error-as-expression "nonterminals") 67 | #:property prop:not-racket-syntax #t) 68 | 69 | (struct simple-nonterm-info (expander)) 70 | (struct nesting-nonterm-info (expander)) 71 | (struct exporting-nonterm-info (pass1-expander pass2-expander)) 72 | 73 | ; var-info is one of: 74 | ; bindclass-rep 75 | ; nonterm-rep 76 | ; nested-binding 77 | (struct pvar-rep (var-info depth)) 78 | 79 | (struct nested-binding []) 80 | (struct special-syntax-class-binding []) 81 | -------------------------------------------------------------------------------- /private/test/rebind-pattern-vars.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../syntax/compile/pattern-var-reflection.rkt" 4 | syntax/parse 5 | syntax/stx 6 | rackunit) 7 | 8 | 9 | (let () 10 | (define/syntax-parse (x ...) #'(1 2 3)) 11 | 12 | (check-equal? 13 | (syntax->datum 14 | (rebind-pattern-vars (x) #f 15 | #'(~? (x ...) ()))) 16 | '()) 17 | 18 | (check-equal? 19 | (syntax->datum 20 | (rebind-pattern-vars (x) (attribute x) 21 | #'(~? (x ...) ()))) 22 | '(1 2 3))) 23 | 24 | (let () 25 | (define (wrap-add1 stx) 26 | #`(+ #,stx 1)) 27 | 28 | (define transformed 29 | (syntax-parse #'(let ([x 5] [y 6]) (+ x y)) 30 | [(form ([v e] ...) b) 31 | (rebind-pattern-vars 32 | (v e b) 33 | (values (attribute v) 34 | (map wrap-add1 (attribute e)) 35 | (wrap-add1 (attribute b))) 36 | #'(form ([v e] ...) b))])) 37 | 38 | (check-equal? 39 | (syntax->datum transformed) 40 | '(let ([x (+ 5 1)] [y (+ 6 1)]) (+ (+ x y) 1))) 41 | 42 | (check-equal? 43 | (eval transformed) 44 | 14)) -------------------------------------------------------------------------------- /private/test/sequence.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax 5 | racket/base 6 | syntax/parse 7 | "../ee-lib/main.rkt" 8 | "../runtime/binding-spec.rkt" 9 | "../syntax/compile/pattern-var-reflection.rkt") 10 | 11 | "../ee-lib/define.rkt") 12 | 13 | (define-literal-forms mylang-lits 14 | "mylang forms may only be used in mylang" 15 | (mylang-let*)) 16 | 17 | (begin-for-syntax 18 | (struct mylang-binding ()) 19 | 20 | (define (mylang-expand-binding-group stx) 21 | (syntax-parse stx 22 | [[v:id e] 23 | (define bspec 24 | (group (list (subexp 'e mylang-expand-expr) 25 | (scope 26 | (group 27 | (list 28 | (bind 'v #f mylang-binding) 29 | (nested))))))) 30 | (expand-function-return 31 | (list bspec) 32 | (hash 33 | 'v (attribute v) 34 | 'e (attribute e)) 35 | (lambda (env) 36 | #`[#,(hash-ref env 'v) #,(hash-ref env 'e)]))])) 37 | 38 | (define (mylang-expand-expr stx) 39 | (syntax-parse stx 40 | #:literal-sets (mylang-lits) 41 | [n:number 42 | #'n] 43 | [v:id 44 | (expand-function-return 45 | (list (ref 'v #f mylang-binding? "unbound mylang var reference")) 46 | (hash 47 | 'v #'v) 48 | (lambda (env) (hash-ref env 'v)))] 49 | [(mylang-let* (b ...) e) 50 | ; #:binding (fold b e) 51 | (define bspec 52 | (nest 'b mylang-expand-binding-group 53 | (subexp 'e mylang-expand-expr))) 54 | 55 | (expand-function-return 56 | (list bspec) 57 | (hash 58 | 'b (attribute b) 59 | 'e (attribute e)) 60 | (lambda (env) 61 | #`(mylang-let* (#,@(hash-ref env 'b)) 62 | #,(hash-ref env 'e))))]))) 63 | 64 | (define-syntax (mylang stx) 65 | (syntax-parse stx 66 | [(_ e) 67 | #`#'#,(expand-top (list (subexp 'e mylang-expand-expr)) (hash 'e #'e) (lambda (env^) (hash-ref env^ 'e)))])) 68 | 69 | (require rackunit syntax/macro-testing) 70 | 71 | (check-equal? 72 | (syntax->datum 73 | (mylang (mylang-let* ([x 5] [y x]) y))) 74 | '(mylang-let* ((x 5) (y x)) y)) 75 | 76 | (check-exn 77 | #rx"y: unbound mylang var reference" 78 | (lambda () 79 | (convert-compile-time-error 80 | (mylang (mylang-let* ([x 5]) y))))) 81 | -------------------------------------------------------------------------------- /private/test/simple-bspec.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | (for-syntax 5 | racket/base 6 | syntax/parse 7 | "../ee-lib/main.rkt" 8 | "../runtime/binding-spec.rkt") 9 | 10 | "../ee-lib/define.rkt") 11 | 12 | (define-literal-forms mylang-lits 13 | "mylang forms may only be used in mylang" 14 | (mylang-let)) 15 | 16 | (begin-for-syntax 17 | (struct mylang-binding ()) 18 | 19 | (define (mylang-expand-expr stx) 20 | (syntax-parse stx 21 | #:literal-sets (mylang-lits) 22 | [n:number 23 | #'n] 24 | [v:id 25 | (expand-function-return 26 | (list (ref 'v #f mylang-binding? "unbound mylang var reference")) 27 | (hash 28 | 'v #'v) 29 | (lambda (env) 30 | (hash-ref env 'v)))] 31 | [(mylang-let ([v e]) b) 32 | (expand-function-return 33 | (list 34 | (group 35 | (list 36 | (subexp 'e mylang-expand-expr) 37 | (scope 38 | (group 39 | (list 40 | (bind 'v #f mylang-binding) 41 | (subexp 'b mylang-expand-expr))))))) 42 | (hash 43 | 'v #'v 44 | 'e #'e 45 | 'b #'b) 46 | (lambda (env) 47 | #`(mylang-let ([#,(hash-ref env 'v) 48 | #,(hash-ref env 'e)]) 49 | #,(hash-ref env 'b))))]))) 50 | 51 | (define-syntax (mylang stx) 52 | (syntax-parse stx 53 | [(_ e) 54 | #`#'#,(expand-top (list (subexp 'e mylang-expand-expr)) (hash 'e #'e) (lambda (env^) (hash-ref env^ 'e)))])) 55 | 56 | (require rackunit syntax/macro-testing) 57 | 58 | (check-equal? 59 | (syntax->datum 60 | (mylang (mylang-let ([x 5]) x))) 61 | '(mylang-let ((x 5)) x)) 62 | 63 | (check-exn 64 | #rx"y: unbound mylang var reference" 65 | (lambda () 66 | (convert-compile-time-error 67 | (mylang (mylang-let ([x 5]) y))))) 68 | -------------------------------------------------------------------------------- /scribblings/common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require scribble/manual) 6 | 7 | (define (tech/reference str) 8 | (tech #:doc '(lib "scribblings/reference/reference.scrbl") str)) 9 | 10 | (define (tech/guide str) 11 | (tech #:doc '(lib "scribblings/guide/guide.scrbl") str)) 12 | 13 | (define (seclink/reference sec str) 14 | (seclink sec #:doc '(lib "scribblings/reference/reference.scrbl") str)) 15 | 16 | (define (seclink/guide sec str) 17 | (seclink sec #:doc '(lib "scribblings/guide/guide.scrbl") str)) -------------------------------------------------------------------------------- /scribblings/main.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket)) 4 | 5 | @title{syntax-spec: A Metalanguage for Hosted DSLs} 6 | @;@title{syntax-spec: Declaring DSL syntaxes} 7 | @author+email["Michael Ballantyne" "michael.ballantyne@gmail.com"] 8 | @author+email["Michael Delmonaco" "mdelmonacochs@gmail.com"] 9 | 10 | 11 | This package provides a metalanguage for creating hosted DSLs. @deftech{Hosted DSLs} extend 12 | the syntax of Racket with their own grammar and have their own static semantics and compilers. 13 | 14 | The metalanguage allows programmers to declare a DSL's grammar, binding rules, and integration points 15 | with Racket. Under the hood it produces a macro expander for the DSL that parses, checks name bindings, 16 | expands DSL macros, and produces syntax in the DSL's core language for compilation. 17 | 18 | You can implement conventional macros that do all these same things, but it can take a lot of manual 19 | effort and a deep knowledge of Racket's syntax API. 20 | 21 | 22 | 23 | You might find the metalanguage useful when you both: 24 | 25 | 26 | 27 | @itemlist[ 28 | @item{want to perform static analysis or optimizing compilation} 29 | @item{you want your DSL to be macro-extensible} 30 | ] 31 | 32 | @local-table-of-contents[] 33 | 34 | @include-section["tutorial/main.scrbl"] 35 | 36 | @include-section["reference/main.scrbl"] 37 | 38 | -------------------------------------------------------------------------------- /scribblings/reference/main.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket)) 4 | 5 | @title[#:style '(toc)]{Reference} 6 | 7 | @require[(for-label "../../main.rkt")] 8 | @defmodule[syntax-spec-dev] 9 | 10 | @local-table-of-contents[] 11 | 12 | @include-section["specifying.scrbl"] 13 | 14 | @include-section["compiling.scrbl"] 15 | 16 | @include-section["versions.scrbl"] -------------------------------------------------------------------------------- /scribblings/reference/versions.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "../common.rkt" (for-label racket syntax-spec-dev racket/stxparam)) 4 | 5 | @title{Release Notes} 6 | 7 | This package is periodically released as a package on the package server with a versioned package and collection name, like @hyperlink["https://pkgs.racket-lang.org/package/syntax-spec-dev"]{@tt{syntax-spec-dev}}. The unversioned package name @tt{syntax-spec} is used for the current unstable development version. 8 | 9 | Breaking changes may occur between differently-named versions. This page documents the history of breaking changes. Other new features are not mentioned here. 10 | 11 | The version used in the paper @hyperlink["https://dl.acm.org/doi/10.1145/3674627"]{"Compiled, Extensible, Multi-language DSLs (Functional Pearl)"} was @tt{syntax-spec-v2}. 12 | 13 | @section[#:style '(unnumbered)]{Version 3} 14 | 15 | Binding specifications now require ellipses matching the ellipsis depth of pattern variables in the syntax spec. See the @hyperlink["https://github.com/michaelballantyne/syntax-spec/pull/37]"]{PR description} for more details. 16 | 17 | With this change the new @tt{nest} syntax accomplishes the behavior of the old @tt{nest} syntax when the first form is followed by ellipses and the behavior of the old @tt{nest-one} syntax when no ellipses are used. 18 | 19 | @tech{Reference compilers} are now specified as part of @tech[#:key "binding classes"]{binding class} declarations, rather than with @tt{with-reference-compilers}. If you previously used @tt{with-reference-compilers} to create reference compilers with contextual behavior, you can typically use @tech/reference{syntax parameters} to accomplish the same with the new design. 20 | 21 | @section[#:style '(unnumbered)]{Version 2} 22 | 23 | Some forms were renamed: 24 | 25 | @tabular[#:style 'boxed 26 | #:row-properties '(bottom-border ()) 27 | (list (list @bold{Old name} @bold{New name}) 28 | (list @tt{recursive} @tt{import}) 29 | (list @tt{nonterminal/two-pass} @tt{nonterminal/exporting}))] 30 | 31 | Scopes in binding specifications are now indicated by the @tt{scope} form rather than @tt{{}} curly braces. 32 | 33 | Reference compilers are now invoked at application forms like @tt{(x y z)} where @tt{x} is the DSL reference. Use @racket[make-variable-like-reference-compiler] if you only want to transform references in reference or @racket[set!] positions. 34 | 35 | -------------------------------------------------------------------------------- /scribblings/tutorial/main.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket)) 4 | 5 | @title[#:style '(toc unnumbered)]{Tutorial} 6 | 7 | The tutorial is broken down into illustrative examples: 8 | 9 | @local-table-of-contents[] 10 | 11 | @include-section["basic-tutorial.scrbl"] 12 | @include-section["stlc-tutorial.scrbl"] 13 | @include-section["multipass-tutorial.scrbl"] 14 | -------------------------------------------------------------------------------- /scribblings/tutorial/multipass-tutorial.scrbl: -------------------------------------------------------------------------------- 1 | 2 | #lang scribble/manual 3 | 4 | @(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../../main.rkt") 5 | scribble/example) 6 | 7 | @title[#:tag "multipass"]{Advanced Tutorial: A Compiler with Multiple Passes} 8 | 9 | This is a stub 10 | -------------------------------------------------------------------------------- /testing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "main.rkt" 4 | syntax/macro-testing 5 | rackunit 6 | racket/exn 7 | (for-syntax racket/base syntax/parse racket/syntax)) 8 | 9 | (provide expand-nonterminal/datum 10 | check-decl-error 11 | check-phase1-error 12 | check-syntax-error 13 | 14 | (all-from-out "main.rkt" 15 | rackunit 16 | syntax/macro-testing) 17 | (for-syntax (all-from-out racket/base syntax/parse))) 18 | 19 | (define-syntax expand-nonterminal/datum 20 | (syntax-parser 21 | [(_ nonterm:id form) 22 | (define/syntax-parse ctx this-syntax) 23 | #'(phase1-eval 24 | (parameterize ([current-syntax-context (quote-syntax ctx)]) 25 | ((nonterminal-expander nonterm) (quote-syntax form))) 26 | #:catch? #t)])) 27 | 28 | (define ((check-formatted-error-matches rx) exn) 29 | ;; I previously used exn->string, but that raised an error 30 | ;; re: writing special values when handling an ambiguous binding 31 | ;; error. 32 | (regexp-match? rx (exn-message exn))) 33 | 34 | (define-syntax-rule (check-decl-error rx decl-stx) 35 | (check-exn 36 | (check-formatted-error-matches rx) 37 | (lambda () 38 | (eval-syntax (quote-syntax 39 | (module m racket/base 40 | (require "../main.rkt") 41 | decl-stx)))))) 42 | 43 | (define-syntax-rule (check-phase1-error rx e) 44 | (check-exn 45 | (check-formatted-error-matches rx) 46 | (lambda () (phase1-eval e #:catch? #t)))) 47 | 48 | (define-syntax-rule (check-syntax-error rx e) 49 | (check-exn 50 | (check-formatted-error-matches rx) 51 | (lambda () (convert-compile-time-error e)))) 52 | -------------------------------------------------------------------------------- /tests/basic-langs/block.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; `racket/block` implementation to test `export-syntax`. 4 | ;; 5 | ;; TODO: multiple macro definitions with single define-syntaxes. 6 | ;; TODO: implement begin? 7 | 8 | (require "../../testing.rkt" 9 | drracket/check-syntax) 10 | 11 | (syntax-spec 12 | (nonterminal/exporting block-form 13 | #:allow-extension racket-macro 14 | 15 | ((~literal define-values) (x:racket-var ...) e:racket-expr) 16 | #:binding [(export x) ...] 17 | 18 | ((~literal define-syntaxes) (x:racket-macro ...) e:expr) 19 | #:binding (export-syntaxes x ... e) 20 | 21 | e:racket-expr) 22 | 23 | (host-interface/expression 24 | (block body:block-form ...) 25 | #:binding (scope (import body) ...) 26 | #'(compile-block body ...))) 27 | 28 | (define-syntax compile-block 29 | (syntax-parser 30 | #:literals (define-values define-syntaxes) 31 | [(_) #'(void)] 32 | [(_ body:expr ... (~and last ((~or define-values define-syntaxes) . _))) 33 | #'(compile-block body ... last (void))] 34 | [(_ (~alt (define-values (val-id ...) val-expr) 35 | (define-syntaxes (trans-id) trans-expr) 36 | expr) 37 | ...) 38 | #`(letrec-syntaxes+values ([(trans-id) trans-expr] ...) 39 | ([(val-id ...) val-expr] ...) 40 | expr 41 | ...)])) 42 | 43 | (check-equal? 44 | (block 1) 45 | 1) 46 | 47 | (check-equal? 48 | (block) 49 | (void)) 50 | 51 | (check-equal? 52 | (block (define (f) (g)) 53 | (define (g) 2) 54 | (f)) 55 | 2) 56 | 57 | (check-equal? 58 | (block 1 59 | (define x 2)) 60 | (void)) 61 | 62 | (check-equal? 63 | (block (define-syntax-rule (m) (f)) 64 | (define (f) 2) 65 | (m)) 66 | 2) 67 | 68 | (check-equal? 69 | (block 70 | (define-syntaxes (one m) (values (syntax-rules () [(one) 1]) 71 | (syntax-rules () [(m stx) stx]))) 72 | (m (one))) 73 | 1) 74 | 75 | ;; TODO this test only works when run without already having built with raco make. Disable for now. 76 | #;(define-namespace-anchor a) 77 | #;(test-case "disappeared props" 78 | (define (num-arrows-of check-syntax-result) 79 | (length (for/list ([vec check-syntax-result] #:when (equal? (vector-ref vec 0) 80 | 'syncheck:add-arrow/name-dup/pxpy)) 81 | vec))) 82 | (define ns (namespace-anchor->namespace a)) 83 | (check-equal? (num-arrows-of 84 | (show-content (quote-syntax (block 85 | (define-syntax x #'a) 86 | (define-syntax m 87 | (syntax-parser 88 | [(_ name:id) 89 | (define/syntax-parse actual-name (syntax-local-value #'name)) 90 | (syntax-property #'(define actual-name 42) 'disappeared-use (list (syntax-local-introduce #'name)))])) 91 | (m x))) 92 | #:namespace ns)) 93 | 2)) 94 | -------------------------------------------------------------------------------- /tests/basic-langs/define-star.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class var #:description "mylang variable") 7 | 8 | (extension-class mylang-macro) 9 | 10 | (nonterminal expr 11 | #:description "mylang expression" 12 | #:allow-extension mylang-macro 13 | 14 | v:var 15 | n:number 16 | (+ e1:expr e2:expr) 17 | 18 | (block d:def-or-expr ...) 19 | #:binding (nest d ... [])) 20 | 21 | (nonterminal/nesting def-or-expr (tail) 22 | #:description "mylang definition context" 23 | #:allow-extension mylang-macro 24 | 25 | (begin d:def-or-expr ...) 26 | #:binding (nest d ... tail) 27 | 28 | (define*-values (v:var ...) e:expr) 29 | #:binding [e (scope (bind v) ... tail)] 30 | 31 | e:expr)) 32 | 33 | (define-syntax define* 34 | (mylang-macro 35 | (syntax-parser 36 | [(_ v e) 37 | #'(define*-values (v) e)]))) 38 | 39 | ;; tests 40 | (check-equal? 41 | (expand-nonterminal/datum expr 42 | (block 43 | (begin 44 | (define* x 5) 45 | (define* x (+ x 1))) 46 | (define* x (+ x 1)) 47 | (+ x 1))) 48 | '(block 49 | (begin 50 | (define*-values (x) 5) 51 | (define*-values (x) (+ x 1))) 52 | (define*-values (x) (+ x 1)) 53 | (+ x 1))) 54 | -------------------------------------------------------------------------------- /tests/basic-langs/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class var #:description "dsl variable") 7 | 8 | (extension-class dsl-macro) 9 | 10 | (nonterminal expr 11 | #:description "dsl expression" 12 | #:allow-extension dsl-macro 13 | 14 | v:var 15 | n:number 16 | (dsl-+ e1:expr e2:expr) 17 | 18 | (dsl-lambda (v:var ...) d:def-or-expr ...) 19 | #:binding (scope (bind v) ... (scope (import d) ...)) 20 | 21 | (dsl-letrec-values ([(v:var ...) rhs:expr] ...) d:def-or-expr) 22 | #:binding (scope (bind v) ... ... rhs ... (scope (import d))) 23 | 24 | (dsl-let* (b:binding ...) e:expr) 25 | #:binding (nest b ... e) 26 | 27 | (v:var e:expr ...)) 28 | 29 | (nonterminal/nesting binding (nested) 30 | #:description "dsl-let* binding group" 31 | 32 | [v:var e:expr] 33 | #:binding [e (scope (bind v) nested)]) 34 | 35 | (nonterminal/exporting def-or-expr 36 | #:description "dsl definition context" 37 | #:allow-extension dsl-macro 38 | 39 | (dsl-begin d:def-or-expr ...) 40 | #:binding [(re-export d) ...] 41 | 42 | (dsl-define-values (v:var ...) e:expr) 43 | #:binding [(export v) ... e] 44 | 45 | e:expr)) 46 | 47 | (define-syntax dsl-define 48 | (dsl-macro 49 | (syntax-parser 50 | [(_ v e) 51 | #'(dsl-define-values (v) e)]))) 52 | 53 | ;; tests 54 | 55 | (check-equal? 56 | (expand-nonterminal/datum expr 57 | (dsl-lambda () 58 | (dsl-define f (f)) 59 | (f))) 60 | '(dsl-lambda () 61 | (dsl-define-values (f) (f)) 62 | (f))) 63 | 64 | (check-equal? 65 | (expand-nonterminal/datum expr 66 | (dsl-lambda () 67 | (dsl-define f (dsl-lambda (f) (f (g)))) 68 | (dsl-begin 69 | (dsl-define g (dsl-lambda () (f)))) 70 | (f))) 71 | '(dsl-lambda () 72 | (dsl-define-values (f) (dsl-lambda (f) (f (g)))) 73 | (dsl-begin 74 | (dsl-define-values (g) (dsl-lambda () (f)))) 75 | (f))) 76 | 77 | (check-equal? 78 | (expand-nonterminal/datum expr 79 | (dsl-letrec-values ([(a b c) (a b c d e f)] 80 | [(d e f) (a b c d e f)]) 81 | (a b c d e f))) 82 | '(dsl-letrec-values ([(a b c) (a b c d e f)] 83 | [(d e f) (a b c d e f)]) 84 | (a b c d e f))) 85 | 86 | (check-exn 87 | #rx"dsl-define-values: identifier already defined" 88 | (lambda () 89 | (expand-nonterminal/datum expr 90 | (dsl-lambda () 91 | (dsl-define x 5) 92 | (dsl-define x 5))))) 93 | 94 | -------------------------------------------------------------------------------- /tests/basic-langs/expr.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class var #:description "expr language variable") 7 | 8 | (nonterminal expr 9 | #:description "simple expr language expression" 10 | 11 | n:number 12 | v:var 13 | (+ e1:expr e2:expr) 14 | 15 | (let ([v:var e:expr] ...) b:expr) 16 | #:binding [e ... (scope (bind v) ... b)] 17 | 18 | (let* (b:binding ...) e:expr) 19 | #:binding (nest b ... e)) 20 | 21 | (nonterminal/nesting binding (nested) 22 | #:description "let* binding group" 23 | 24 | [v:var e:expr] 25 | #:binding [e (scope (bind v) nested)])) 26 | 27 | (check-equal? 28 | (expand-nonterminal/datum expr 29 | (let ([x 5]) (let ([x (+ x 1)]) x))) 30 | '(let ([x 5]) (let ([x (+ x 1)]) x))) 31 | 32 | (check-equal? 33 | (expand-nonterminal/datum expr 34 | (let* ([x 5] [x (+ x 1)]) x)) 35 | '(let* ([x 5] [x (+ x 1)]) x)) 36 | 37 | (check-exn 38 | #rx"y: not bound as expr language variable" 39 | (lambda () 40 | (convert-compile-time-error 41 | (expand-nonterminal/datum expr (let* ([x 5]) y))))) 42 | -------------------------------------------------------------------------------- /tests/basic-langs/mutual-recursion.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class var #:description "while-language variable") 7 | 8 | (extension-class expr-macro) 9 | (extension-class stmt-macro) 10 | 11 | (nonterminal expr 12 | #:description "while-language expression" 13 | 14 | n:number 15 | 16 | v:var 17 | 18 | (+ e1:expr e2:expr) 19 | (< e1:expr e2:expr) 20 | 21 | (vars (v:var ...) e:expr) 22 | #:binding (scope (bind v) ... e) 23 | 24 | (do s:stmt ... e:expr)) 25 | 26 | (nonterminal stmt 27 | #:description "while-language statement" 28 | #:allow-extension stmt-macro 29 | 30 | (set v:var e:expr) 31 | 32 | (print e:expr) 33 | 34 | (while e:expr 35 | s:stmt ...) 36 | 37 | (stmts s:stmt ...))) 38 | 39 | ;; sugar 40 | (define-syntax for 41 | (stmt-macro 42 | (syntax-parser 43 | [(_ [init cond incr] stmt ...) 44 | #'(stmts 45 | init 46 | (while cond 47 | stmt ... 48 | incr))]))) 49 | 50 | ;; tests 51 | 52 | (check-equal? 53 | (expand-nonterminal/datum expr 54 | (vars (i x) 55 | (do 56 | (set x 5) 57 | (for [(set i 0) (< i x) (set i (+ i 1))] 58 | (print i)) 59 | i))) 60 | (expand-nonterminal/datum expr 61 | (vars (i x) 62 | (do 63 | (set x 5) 64 | 65 | (stmts 66 | (set i 0) 67 | (while (< i x) 68 | (print i) 69 | (set i (+ i 1)))) 70 | 71 | i)))) 72 | -------------------------------------------------------------------------------- /tests/basic-langs/racket-macro.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | 6 | (syntax-spec 7 | (extension-class expr-macro) 8 | 9 | (binding-class var #:description "expr language variable") 10 | 11 | (nonterminal expr 12 | #:description "simple expr language expression" 13 | #:allow-extension (expr-macro racket-macro) 14 | 15 | n:number 16 | v:var 17 | (+ e1:expr e2:expr) 18 | 19 | (let ([v:var e:expr] ...) b:expr) 20 | #:binding [e ... (scope (bind v) ... b)])) 21 | 22 | (define-syntax let* 23 | (syntax-rules () 24 | [(let* () body) body] 25 | [(let* ([x rhs] binding ...) body) 26 | (let ([x rhs]) 27 | (let* (binding ...) body))])) 28 | 29 | (define-syntax expr-identity 30 | (expr-macro (syntax-rules () [(_ e) e]))) 31 | 32 | (check-equal? 33 | (expand-nonterminal/datum expr 34 | (let ([x 5]) (let ([x (+ x 1)]) x))) 35 | '(let ([x 5]) (let ([x (+ x 1)]) x))) 36 | 37 | (check-equal? 38 | (expand-nonterminal/datum expr 39 | (let* ([x 5] [x (+ x 1)]) (expr-identity x))) 40 | '(let ([x 5]) (let ([x (+ x 1)]) x))) 41 | -------------------------------------------------------------------------------- /tests/basic-langs/racket-var.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; this tests the built-in racket-var binding class 4 | 5 | (require "../../testing.rkt") 6 | 7 | (syntax-spec 8 | (nonterminal my-expr 9 | ((~literal let) ([x:racket-var e:racket-expr] ...) b:racket-expr) 10 | #:binding (scope (bind x) ... b)) 11 | 12 | (host-interface/expression 13 | (eval-my-expr e:my-expr) 14 | #'e)) 15 | 16 | (check-equal? 17 | (eval-my-expr (let ([x 2]) (let ([y x] [z x]) (list y z)))) 18 | '(2 2)) 19 | -------------------------------------------------------------------------------- /tests/basic-langs/simple-match.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class var #:description "mylang variable") 7 | 8 | (extension-class mylang-macro) 9 | 10 | (nonterminal expr 11 | #:description "mylang expression" 12 | #:allow-extension mylang-macro 13 | 14 | v:var 15 | 16 | n:number 17 | (+ e1:expr e2:expr) 18 | 19 | (empty) 20 | (cons e1:expr e2:expr) 21 | 22 | ;; note that lack of explicit ... in binding specs means 23 | ;; we need to use a match-clause nonterminal 24 | (match e:expr c:match-clause ...)) 25 | 26 | (nonterminal match-clause 27 | #:description "mylang match clause" 28 | 29 | [p:pat rhs:expr] 30 | #:binding (nest p rhs)) 31 | 32 | (nonterminal/nesting pat (nested) 33 | #:description "mylang match pattern" 34 | 35 | v:var 36 | #:binding (scope (bind v) nested) 37 | 38 | (pempty) 39 | 40 | (pcons p1:pat p2:pat) 41 | #:binding (nest p1 (nest p2 nested)))) 42 | 43 | (define-syntax define* 44 | (mylang-macro 45 | (syntax-parser 46 | [(_ v e) 47 | #'(define*-values (v) e)]))) 48 | 49 | ;; tests 50 | (check-equal? 51 | (expand-nonterminal/datum expr 52 | (match (cons 1 (cons 2 (empty))) 53 | [(pcons a (pcons b (pempty))) 54 | (+ a b)])) 55 | '(match (cons 1 (cons 2 (empty))) 56 | [(pcons a (pcons b (pempty))) 57 | (+ a b)])) 58 | -------------------------------------------------------------------------------- /tests/colon-form.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; ensures that you can use colon as the name of a form 4 | 5 | (require "../testing.rkt") 6 | 7 | (syntax-spec 8 | (nonterminal bt 9 | (: l:bt r:bt) 10 | leaf) 11 | 12 | (host-interface/expression 13 | (make-bt e:bt) 14 | (syntax-parse #'e 15 | [((~literal :) l r) 16 | #'(list (make-bt l) (make-bt r))] 17 | [(~literal leaf) 18 | #''()]))) 19 | 20 | (check-equal? (make-bt (: leaf (: leaf leaf))) 21 | '(() (() ()))) 22 | -------------------------------------------------------------------------------- /tests/datum-matching.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../testing.rkt") 4 | 5 | ;; It is often easiest to use datum-literal matching in the DSL 6 | ;; compiler, especially if the DSL syntax uses binding spaces. 7 | 8 | (provide dsl (for-space dsl +)) 9 | 10 | (syntax-spec 11 | (nonterminal expr 12 | #:binding-space dsl 13 | 14 | n:number 15 | (+ e1:expr e2:expr)) 16 | 17 | (host-interface/expression 18 | (dsl e:expr) 19 | #'(compile-dsl e))) 20 | 21 | (define-syntax (compile-dsl stx) 22 | (syntax-parse stx 23 | #:datum-literals (+) 24 | [(_ n:number) 25 | #'n] 26 | [(_ (+ e1 e2)) 27 | #'(+ (compile-dsl e1) (compile-dsl e2))])) 28 | 29 | (check-equal? 30 | (dsl (+ 1 2)) 31 | 3) 32 | 33 | 34 | (module* test racket 35 | (require (rename-in (submod "..") [+ dsl-+]) 36 | rackunit) 37 | 38 | (check-equal? 39 | (+ 1 2) 40 | 3) 41 | 42 | ;; Check that the expander constructs output syntax with the 43 | ;; symbol used in the syntax-spec and not the symbol from the 44 | ;; input syntax; otherwise this example would not compile. 45 | (check-equal? 46 | (dsl (dsl-+ 1 2)) 47 | 3)) 48 | 49 | -------------------------------------------------------------------------------- /tests/definition-interface.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../main.rkt" 4 | rackunit) 5 | 6 | (syntax-spec 7 | (binding-class dsl-var) 8 | (nonterminal dsl-e 9 | n:number) 10 | 11 | (host-interface/definition 12 | (dsl-def x:dsl-var rhs:dsl-e) 13 | #:binding (export x) 14 | 15 | #:lhs 16 | [#'x] 17 | #:rhs 18 | [#''rhs]) 19 | 20 | (host-interface/expression 21 | (dsl-ref v:dsl-var) 22 | #'v)) 23 | 24 | (define f (lambda () (dsl-ref x))) 25 | (dsl-def x 5) 26 | (check-equal? 27 | (f) 28 | 5) 29 | 30 | (let () 31 | (define f (lambda () (dsl-ref x))) 32 | (dsl-def x 6) 33 | (check-equal? 34 | (f) 35 | 6)) 36 | -------------------------------------------------------------------------------- /tests/dsls/cmdline/concepts.md: -------------------------------------------------------------------------------- 1 | sloc: 222 for both 2 | 3 | apis: 4 | apply-as-transformer 5 | define/hygienic-metafunction 6 | lookup 7 | 8 | patterns: 9 | writing expanders 10 | types of transformers 11 | 12 | 13 | -------------------------------------------------------------------------------- /tests/dsls/cmdline/example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "cmdline.rkt" "sugar.rkt" (for-syntax racket/base syntax/parse)) 4 | 5 | (define (existing-file/p str) 6 | (if (file-exists? str) 7 | str 8 | (raise-user-error "expected path to exisiting file"))) 9 | 10 | (module+ main 11 | (define/command-line-options 12 | #:options 13 | [verbose-mode (switch/o ("-v" "--verbose") "Compile with verbose messages")] 14 | [profiling-on (switch/o ("-p" "--profile") "Compile with profiling")] 15 | [optimize-level 16 | (choice/o #:default 0 17 | ["--optimize-level" [lvl (int-range/p 0 3)] 18 | "set optimization level to " lvl] 19 | (numbered-flags/f "--o" [0 3] "optimization level"))] 20 | [output 21 | (required/o "-o" outfile "the output filename" outfile)] 22 | [link-flags (list/o 23 | [["-l" "--link-flags"] lf "Add a flag for the linker"])] 24 | #:arguments 25 | [file-to-compile existing-file/p])) 26 | -------------------------------------------------------------------------------- /tests/dsls/cmdline/sugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require "cmdline.rkt" (for-syntax racket/base syntax/parse)) 5 | 6 | (define-option-syntax switch/o 7 | (syntax-parser 8 | [(_ flags:flag-names desc:string) 9 | #'(choice/o #:default #f [flags desc #t])])) 10 | 11 | (define-option-syntax list/o 12 | (syntax-parser 13 | [(_ [names:flag-names arg:arg-spec desc:string (~optional transformed #:defaults ([transformed #'arg.name]))] ...) 14 | #'(multi/o '() 15 | [names arg desc (lambda (acc) (append acc (list transformed)))] ...)])) 16 | 17 | (define (int-range/p min max) 18 | (lambda (s) 19 | (define n (string->number s)) 20 | (unless (and (integer? n) (>= n min) (<= n max)) 21 | (raise-user-error (format "expected integer between ~a and ~a" min max))) 22 | n)) 23 | 24 | (define-option-syntax optional/o 25 | (syntax-parser 26 | [(_ #:default default-expr rest ...) 27 | #'(choice/o #:default default-expr [rest ...])])) 28 | 29 | (define-option-syntax required/o 30 | (syntax-parser 31 | [(_ rest ...) 32 | #'(choice/o #:required [rest ...])])) 33 | 34 | (define-flag-syntax numbered-flags/f 35 | (syntax-parser 36 | [(_ flags:flag-names [min:number max:number] desc:string) 37 | (define/syntax-parse (f ...) 38 | (for/list ([n (in-range (syntax-e #'min) (+ 1 (syntax-e #'max)))]) 39 | (define/syntax-parse names (for/list ([s (syntax->datum #'flags.names)]) (format "~a~a" s n))) 40 | (define/syntax-parse this-desc (format "set ~a to ~a" (syntax-e #'desc) n)) 41 | #`[names this-desc #,n])) 42 | #'(begin f ...)])) 43 | -------------------------------------------------------------------------------- /tests/dsls/js/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "dependencies": { 3 | "escodegen": "^2.0.0" 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /tests/dsls/js/runjs.js: -------------------------------------------------------------------------------- 1 | const util = require('util'); 2 | const escodegen = require('escodegen') 3 | const vm = require("vm") 4 | 5 | const read_stdin = util.promisify(function(callback) { 6 | var inputChunks = []; 7 | 8 | process.stdin.resume(); 9 | process.stdin.setEncoding('utf8'); 10 | 11 | process.stdin.on('data', function (chunk) { 12 | inputChunks.push(chunk); 13 | }); 14 | 15 | process.stdin.on('end', function () { 16 | callback(undefined, inputChunks.join()); 17 | }); 18 | }); 19 | 20 | function eval_module(text) { 21 | return vm.runInNewContext(text, {setImmediate: setImmediate, console: console, require: require, process: process}); 22 | } 23 | 24 | 25 | read_stdin() 26 | .then(function(res) { 27 | const program = escodegen.generate(JSON.parse(res)); 28 | process.stderr.write(program + "\n") 29 | console.log(eval_module(program)) 30 | }) 31 | 32 | 33 | -------------------------------------------------------------------------------- /tests/dsls/matthews-findler/ml.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require syntax-spec-dev (for-syntax racket/base syntax/parse)) 4 | 5 | (syntax-spec 6 | (binding-class ml-var #:binding-space ml) 7 | 8 | (nonterminal ml-expr 9 | #:binding-space ml 10 | x:ml-var 11 | n:number 12 | (app e1:ml-expr e2:ml-expr) 13 | (+ e1:ml-expr e2:ml-expr) 14 | (- e1:ml-expr e2:ml-expr) 15 | (if0 e1:ml-expr e2:ml-expr e3:ml-expr) 16 | (lambda ([x:ml-var t:ml-type]) e:ml-expr) 17 | #:binding (scope (bind x) e) 18 | 19 | (~> (e1 e2) 20 | #'(app e1 e2))) 21 | 22 | (nonterminal ml-type 23 | #:binding-space ml 24 | Nat 25 | (-> t1:ml-type t2:ml-type)) 26 | 27 | (host-interface/expression 28 | (ml e:ml-expr) 29 | (infer-type #'e) 30 | #'(ml->racket e))) 31 | 32 | (begin-for-syntax 33 | ;; No type variables yet, so should just be datum equality. 34 | (define (assert-type-equal! actual expected term) 35 | (unless (equal? (syntax->datum actual) (syntax->datum expected)) 36 | (raise-syntax-error 'ml 37 | (format "type mismatch: expected ~a, found ~a" 38 | (syntax->datum expected) 39 | (syntax->datum actual)) 40 | term 41 | #f 42 | (list actual expected)))) 43 | 44 | (define-local-symbol-table type-env) 45 | 46 | (define (type-env-ref x) 47 | (symbol-table-ref type-env x #'Nat)) 48 | 49 | (define (type-env-extend! x t) 50 | (symbol-table-set! type-env x t)) 51 | 52 | (define (infer-type e) 53 | (syntax-parse e 54 | #:datum-literals (app + - if0 lambda) 55 | [x:id 56 | (type-env-ref #'x)] 57 | [_:number 58 | #'Nat] 59 | [(app e1 e2) 60 | (define t1 (infer-type #'e1)) 61 | (syntax-parse t1 62 | #:datum-literals (->) 63 | [(-> argt rett) 64 | (check-type! #'e2 #'argt) 65 | #'rett])] 66 | [(+ e1 e2) 67 | (check-type! #'e1 #'Nat) 68 | (check-type! #'e2 #'Nat) 69 | #'Nat] 70 | [(- e1 e2) 71 | (check-type! #'e1 #'Nat) 72 | (check-type! #'e2 #'Nat) 73 | #'Nat] 74 | [(if0 e1 e2 e3) 75 | (check-type! #'e1 #'Nat) 76 | (define t2 (infer-type #'e2)) 77 | (check-type! #'e3 t2) 78 | t2] 79 | [(lambda ([x xt]) b) 80 | (type-env-extend! #'x #'xt) 81 | (define/syntax-parse rett (infer-type #'b)) 82 | #'(-> xt rett)])) 83 | 84 | (define (check-type! e t) 85 | (assert-type-equal! (infer-type e) t e))) 86 | 87 | (define-syntax ml->racket 88 | (syntax-parser 89 | #:datum-literals (app + - if0 lambda) 90 | [(_ x:id) 91 | #'x] 92 | [(_ n:number) 93 | #'n] 94 | [(_ (app e1 e2)) 95 | #'((ml->racket e1) (ml->racket e2))] 96 | [(_ (+ e1 e2)) 97 | #'(+ (ml->racket e1) (ml->racket e2))] 98 | [(_ (- e1 e2)) 99 | #'(max (- (ml->racket e1) (ml->racket e2)) 0)] 100 | [(_ (if0 e1 e2 e3)) 101 | #'(if (zero? (ml->racket e1)) (ml->racket e2) (ml->racket e3))] 102 | [(_ (lambda ([x t]) b)) 103 | #'(lambda (x) (ml->racket b))])) 104 | 105 | (ml ((lambda ([x Nat]) (- x 1)) 0)) -------------------------------------------------------------------------------- /tests/dsls/miniclass/README.md: -------------------------------------------------------------------------------- 1 | ## miniclass 2 | 3 | An implementation of a small class language supporting fields, methods, local macro definitions, and `this` (but no inheritance). 4 | 5 | Originally developed with Michael Delmonaco at https://github.com/quasarbright/miniclass 6 | 7 | See that repository for comparisons with other implementation 8 | strategies. 9 | -------------------------------------------------------------------------------- /tests/dsls/minikanren-binding-space-compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../../testing.rkt" 4 | "minikanren-binding-space.rkt" 5 | (for-syntax syntax/id-table)) 6 | 7 | (begin-for-syntax 8 | (define compiled-var (make-free-id-table)) 9 | 10 | (define compile-goal 11 | (syntax-parser 12 | #:datum-literals (fresh1 ==) 13 | [(fresh1 (v ...) b) 14 | #`(let ([v (gensym)] ...) 15 | #,(compile-goal #'b))] 16 | [(== t1 t2) 17 | #`(list #,(compile-term #'t1) #,(compile-term #'t2))])) 18 | 19 | (define compile-term 20 | (syntax-parser 21 | #:datum-literals (rkt #%term-ref) 22 | [n:number 23 | #'n] 24 | [(#%term-ref x) 25 | #'x] 26 | [(rkt e) 27 | #'(with-reference-compilers ([term-variable immutable-reference-compiler]) 28 | e)]))) 29 | 30 | (syntax-spec 31 | (host-interface/expression 32 | (run n:expr (qvar:term-variable ...) 33 | g:goal) 34 | #:binding (scope (bind qvar) ... g) 35 | 36 | #`(let ([qvar (gensym)] ...) 37 | #,(compile-goal #'g)))) 38 | 39 | (check-true 40 | (pair? 41 | (run 3 (q) 42 | (fresh (x) 43 | (== q x))))) 44 | 45 | 46 | -------------------------------------------------------------------------------- /tests/dsls/minikanren-compile-defs-min.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "minikanren-compile-defs.rkt") 4 | 5 | (#%expression (run 1 (q) (oddo 5) (eveno 4))) 6 | 7 | (mk-defs 8 | (define-relation2 (eveno n) 9 | (oddo n)) 10 | (define-relation2 (oddo n) 11 | (eveno n))) -------------------------------------------------------------------------------- /tests/dsls/minikanren-compile-defs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide run (all-from-out "minikanren.rkt") mk-defs define-relation define-relation2) 4 | 5 | (require "../../testing.rkt" 6 | "minikanren.rkt" 7 | (for-syntax syntax/id-table)) 8 | 9 | (begin-for-syntax 10 | (define compile-goal 11 | (syntax-parser 12 | #:literals (== fresh) 13 | [(fresh1 (v ...) b) 14 | #`(let ([v (gensym)] ...) 15 | #,(compile-goal #'b))] 16 | [(== t1 t2) 17 | #`(list #,(compile-term #'t1) #,(compile-term #'t2))])) 18 | 19 | (define compile-term 20 | (syntax-parser 21 | #:literals (rkt) 22 | [n:number 23 | #'n] 24 | [(rkt e) 25 | #'e]))) 26 | 27 | (syntax-spec 28 | (host-interface/expression 29 | (run n:expr (qvar:term-variable ...) 30 | g:goal ...) 31 | #:binding (scope (bind qvar) ... g ...) 32 | 33 | #'(void)) 34 | 35 | (host-interface/expression 36 | (mk-compile g:goal) 37 | 38 | (compile-goal #'g)) 39 | 40 | (host-interface/definitions 41 | (define-relation (name:relation-name arg:term-variable ...) body:goal) 42 | #:binding [(export name) (scope (bind arg) ... body)] 43 | #'(define tmp 5))) 44 | 45 | 46 | (syntax-spec 47 | (nonterminal/exporting mk-def 48 | (define-relation2 (name:relation-name arg:term-variable ...) body:goal) 49 | #:binding [(export name) (scope (bind arg) ... body)]) 50 | 51 | (host-interface/definitions 52 | (mk-defs d:mk-def ...) 53 | #:binding [(re-export d) ...] 54 | #'(define tmp 5))) 55 | 56 | 57 | (define-relation (appendo2 l1 l2 l3) 58 | (== l1 '())) 59 | 60 | (run 1 (q) (appendo2 '() '() '())) 61 | 62 | (#%expression (run 1 (q) (oddo 5) (eveno 4))) 63 | 64 | (mk-defs 65 | (define-relation2 (eveno n) 66 | (oddo n)) 67 | (define-relation2 (oddo n) 68 | (eveno n))) 69 | 70 | 71 | 72 | (mk-compile 73 | (fresh (x) 74 | (== 1 (rkt x)))) 75 | 76 | (run 3 (q) 77 | (fresh (x) 78 | (== q x))) 79 | 80 | 81 | -------------------------------------------------------------------------------- /tests/dsls/minikanren-compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../../testing.rkt" 4 | "minikanren.rkt" 5 | (for-syntax syntax/id-table)) 6 | 7 | (begin-for-syntax 8 | (define compile-goal 9 | (syntax-parser 10 | #:literals (== fresh) 11 | [(fresh1 (v ...) b) 12 | #`(let ([v (gensym)] ...) 13 | #,(compile-goal #'b))] 14 | [(== t1 t2) 15 | #`(list #,(compile-term #'t1) #,(compile-term #'t2))])) 16 | 17 | (define compile-term 18 | (syntax-parser 19 | #:literals (rkt) 20 | [n:number 21 | #'n] 22 | [(rkt e) 23 | #'e]))) 24 | 25 | (syntax-spec 26 | (host-interface/expression 27 | (run n:expr (qvar:term-variable ...) 28 | g:goal ...) 29 | #:binding (scope (bind qvar) ... g ...) 30 | 31 | #'(void)) 32 | 33 | 34 | (host-interface/expression 35 | (mk-compile g:goal) 36 | 37 | (compile-goal #'g))) 38 | 39 | 40 | (mk-compile 41 | (fresh (x) 42 | (== 1 (rkt x)))) 43 | 44 | (run 3 (q) 45 | (fresh (x) 46 | (== q x))) 47 | 48 | 49 | -------------------------------------------------------------------------------- /tests/dsls/peg.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (begin-for-syntax 6 | (define-syntax-class string 7 | (pattern val #:when (string? (syntax-e #'val))))) 8 | 9 | (syntax-spec 10 | (binding-class var #:description "PEG variable") 11 | (binding-class nonterm #:description "PEG nonterminal") 12 | (extension-class peg-macro #:description "PEG macro") 13 | 14 | (nonterminal expr 15 | #:description "PEG action expression" 16 | v:var 17 | s:string 18 | (list e:expr ...)) 19 | 20 | (nonterminal peg-top 21 | n:peg #:binding (nest n [])) 22 | 23 | (nonterminal/nesting peg (tail) 24 | #:description "PEG expression" 25 | #:allow-extension peg-macro 26 | 27 | n:nonterm ; confusing! Probably shouldn't use pegs as the paper example... 28 | (eps) ; can't just be `eps` yet. 29 | 30 | (seq e1:peg e2:peg) 31 | #:binding (nest e1 (nest e2 tail)) 32 | 33 | (alt e1:peg e2:peg) 34 | #:binding [(nest e1 []) (nest e2 [])] 35 | 36 | (repeat e:peg) ; * 37 | #:binding (nest e []) 38 | 39 | (not e:peg) ; ! 40 | #:binding (nest e []) 41 | 42 | (bind x:var e:peg) ; : 43 | #:binding (scope (bind x) (nest e []) tail) 44 | 45 | (=> pe:peg e:expr) 46 | #:binding (nest pe e) 47 | 48 | (text e:expr) ; right now these are referring to the expr syntax class. Need escape to Racket... 49 | 50 | (char e:expr) 51 | (token e:expr) 52 | (src-span v:var e:peg) 53 | #:binding (scope (nest e [])) 54 | 55 | ;; can't do implicit #%peg-datum yet. 56 | 57 | )) 58 | 59 | (check-equal? 60 | (expand-nonterminal/datum peg-top 61 | (=> (seq (bind a (text "a")) (bind b (=> (bind c (text "b")) 62 | (list a c)))) 63 | (list a b))) 64 | '(=> (seq (bind a (text "a")) (bind b (=> (bind c (text "b")) 65 | (list a c)))) 66 | (list a b))) 67 | -------------------------------------------------------------------------------- /tests/dsls/peg/.gitignore: -------------------------------------------------------------------------------- 1 | **/*~ 2 | **/compiled 3 | -------------------------------------------------------------------------------- /tests/dsls/peg/ARTIFACT.md: -------------------------------------------------------------------------------- 1 | We created this DSL from scratch. The components are as follows: 2 | 3 | | Component | Location | 4 | | --------- | -------- | 5 | | Runtime | `private/runtime.rkt` | 6 | | Environment representations for nonterminals and macros | `private/env-rep.rkt` | 7 | | Core form literals definitions | `private/forms.rkt` | 8 | | Expander | `private/expand.rkt` | 9 | | Left-recursion static check | `private/leftrec-check.rkt` | 10 | | Compiler | `private/compile.rkt` | 11 | | Optimization for text alternatives | `private/compile-alt-str.rkt` | 12 | | Interface macros | `core.rkt` | 13 | | Syntactic sugar | `main.rkt` | 14 | 15 | -------------------------------------------------------------------------------- /tests/dsls/peg/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "core.rkt" 5 | syntax/srcloc 6 | (for-syntax racket/base syntax/parse)) 7 | 8 | (provide 9 | (except-out (all-from-out "core.rkt") seq alt) 10 | (struct-out parse-result) 11 | define-peg-syntax-parser 12 | (rename-out 13 | [seq* seq] 14 | [alt* alt]) 15 | any-char 16 | char-range 17 | 18 | symbol-token 19 | string-token 20 | predicate-token 21 | syntax-token 22 | 23 | use-literal-token-interpretation) 24 | 25 | (define-syntax-rule 26 | (define-peg-syntax-parser name clause ...) 27 | (define-syntax name 28 | (peg-macro 29 | (syntax-parser 30 | clause ...)))) 31 | 32 | (define-peg-syntax-parser seq* 33 | [(_ p:expr) #'p] 34 | [(_ p1:expr p+:expr ...+) 35 | #'(seq p1 (seq* p+ ...))]) 36 | 37 | (define-peg-syntax-parser alt* 38 | [(_ p:expr) #'p] 39 | [(_ p1:expr p+:expr ...+) 40 | #'(alt p1 (alt* p+ ...))]) 41 | 42 | (define-peg-syntax-parser any-char 43 | [_:id #'(char (lambda (x) #t))]) 44 | 45 | (define-peg-syntax-parser char-range 46 | [(_ lower:character upper:character) 47 | #'(char (lambda (c) (and (char>=? lower c) (char<=? c upper))))]) 48 | 49 | (define-peg-syntax-parser symbol-token 50 | [(_ (~or v:string v:id)) 51 | (define/syntax-parse s (if (symbol? (syntax-e #'v)) 52 | #'v 53 | (datum->syntax #'v (string->symbol (syntax-e #'v))))) 54 | #'(token (lambda (t) (values (and (eq? t 's) t) #f)))]) 55 | 56 | (define-peg-syntax-parser string-token 57 | [(_ s:string) 58 | #'(token (lambda (t) (values (and (equal? t 's) t) #f)))]) 59 | 60 | (define-peg-syntax-parser syntax-token 61 | [(_ x:string) 62 | (define/syntax-parse x-sym (string->symbol (syntax->datum #'x))) 63 | #'(token (lambda (s) 64 | (if (equal? 'x-sym (syntax-e s)) 65 | (values s (build-source-location s)) 66 | (values #f #f))))]) 67 | 68 | (define-peg-syntax-parser predicate-token 69 | [(_ e:expr) 70 | #'(token (lambda (t) (values (and (e t) t) #f)))]) 71 | 72 | (define-syntax use-literal-token-interpretation 73 | (syntax-parser 74 | [(_ id) 75 | (define/syntax-parse this-#%peg-datum (datum->syntax this-syntax '#%peg-datum)) 76 | #'(define-syntax this-#%peg-datum (make-rename-transformer #'id))])) 77 | 78 | -------------------------------------------------------------------------------- /tests/dsls/peg/private/forms.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | (all-defined-out) 5 | (for-syntax peg-literals)) 6 | 7 | (require 8 | (for-syntax 9 | syntax/parse)) 10 | 11 | (begin-for-syntax 12 | (define-literal-set peg-literals 13 | #:datum-literals 14 | (eps 15 | seq 16 | alt 17 | plain-alt 18 | ? 19 | * 20 | repeat 21 | ! 22 | : 23 | bind 24 | => 25 | text 26 | char 27 | token 28 | :src-span 29 | src-span 30 | #%nonterm-ref 31 | ) 32 | ())) 33 | -------------------------------------------------------------------------------- /tests/dsls/peg/private/leftrec-check.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | run-leftrec-check! 5 | expanded-defs) 6 | 7 | (require 8 | syntax/id-table 9 | syntax/parse 10 | "../../../../private/ee-lib/persistent-id-table.rkt" 11 | (except-in "../../../../private/ee-lib/main.rkt" racket-var) 12 | 13 | (for-template 14 | "forms.rkt")) 15 | 16 | (define-local-symbol-table expanded-defs) 17 | (define-persistent-symbol-table def-nullable?) 18 | (define-local-symbol-table entered) 19 | 20 | (define (nullable? stx) 21 | (syntax-parse stx 22 | #:literal-sets (peg-literals) 23 | [eps #t] 24 | [(seq e1 e2) 25 | (and (nullable? #'e1) 26 | (nullable? #'e2))] 27 | [(plain-alt e1 e2) 28 | (or (nullable? #'e1) 29 | (nullable? #'e2))] 30 | [(alt e1 e2) 31 | (or (nullable? #'e1) 32 | (nullable? #'e2))] 33 | [(? e) #t] 34 | [(* e) #t] 35 | [(! e) 36 | (not (nullable? #'e))] 37 | [(bind x e) 38 | (nullable? #'e)] 39 | [(=> pe e) 40 | (nullable? #'pe)] 41 | [(text t) #f] 42 | [(token f) #f] 43 | [(char f) #f] 44 | [((~datum #%nonterm-ref) name:id) 45 | (nullable-nonterminal? #'name)] 46 | [(src-span v e) 47 | (nullable? #'e)] 48 | [_ (raise-syntax-error #f "not a core peg form" this-syntax)])) 49 | 50 | (define (nullable-nonterminal? id) 51 | (case (or (symbol-table-ref def-nullable? id (lambda () #f)) (symbol-table-ref entered id (lambda () #f)) 'unvisited) 52 | [(nullable) #t] 53 | [(not-nullable) #f] 54 | [(entered) (raise-syntax-error #f "left recursion through nonterminal" id)] 55 | [(unvisited) 56 | (symbol-table-set! entered id 'entered) 57 | (define rhs (symbol-table-ref expanded-defs id)) 58 | (define res (nullable? rhs)) 59 | (symbol-table-set! def-nullable? id (if res 'nullable 'not-nullable)) 60 | res])) 61 | 62 | #;((listof identifier?) (listof syntax?) -> void?) 63 | ; run a leftrec check on the given block of mutually recursive peg defs 64 | (define (run-leftrec-check! names pegs) 65 | (for ([name names] 66 | [rhs pegs]) 67 | (symbol-table-set! 68 | expanded-defs 69 | name 70 | rhs)) 71 | (for ([name names]) 72 | (nullable-nonterminal? name))) 73 | -------------------------------------------------------------------------------- /tests/dsls/peg/private/test/case.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | rackunit 5 | (submod "../compile-alt-str.rkt" case)) 6 | 7 | (define (f v) 8 | (int-case v 9 | [1 'a] 10 | [2 'b] 11 | [3 'c] 12 | [4 'd] 13 | [5 'e] 14 | [6 'f] 15 | [7 'g] 16 | [else #f])) 17 | 18 | (define (g v) 19 | (char-case v 20 | [#\a 'a] 21 | [#\b 'b] 22 | [#\d 'd] 23 | [#\e 'e] 24 | [#\f 'f] 25 | [#\g 'g] 26 | [#\h 'h] 27 | [else #f])) 28 | 29 | (check-equal? 30 | (map f '(1 2 3 4 5 6 7 0 9)) 31 | '(a b c d e f g #f #f)) 32 | 33 | (check-equal? 34 | (map g (string->list "abcdefghi")) 35 | '(a b #f d e f g h #f)) -------------------------------------------------------------------------------- /tests/dsls/peg/test/binops.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt" 4 | (for-syntax racket/base syntax/parse)) 5 | 6 | (use-literal-token-interpretation string-token) 7 | 8 | (struct binop-ast [lhs op rhs] #:transparent) 9 | (struct prefix-ast [op rhs] #:transparent) 10 | 11 | (define (left-associate-binops e1 op* e*) 12 | (foldl (lambda (op e base) (binop-ast base op e)) 13 | e1 op* e*)) 14 | 15 | (define-syntax binops 16 | (peg-macro 17 | (lambda (stx) 18 | (syntax-parse stx 19 | [(_ op-e subexpr-e) 20 | #'(=> (seq (: e1 subexpr-e) (* (seq (: op* op-e) (: e* subexpr-e)))) 21 | (left-associate-binops e1 op* e*))])))) 22 | 23 | (define-syntax prefix 24 | (peg-macro 25 | (lambda (stx) 26 | (syntax-parse stx 27 | [(_ op-e subexpr-e) 28 | #'(alt 29 | (=> (seq (: op op-e) (: arg subexpr-e)) 30 | (prefix-ast op arg)) 31 | subexpr-e)])))) 32 | 33 | (define-peg expr (alt "True" "False" (predicate-token number?))) 34 | 35 | (define-peg comp-op 36 | (alt "<" ">" "==" ">=" "<=" "!=" "in" (seq "not" "in") (seq "is" "not") "is")) 37 | 38 | (define-peg or-test 39 | (binops "or" 40 | (binops "and" 41 | (prefix "not" 42 | (binops comp-op 43 | expr))))) 44 | 45 | (module+ test 46 | (require rackunit) 47 | 48 | (check-equal? 49 | (parse-result-value (parse expr '(1))) 50 | 1) 51 | 52 | (check-equal? 53 | (parse-result-value (parse or-test '(1 "and" 1 "<" 2))) 54 | (binop-ast 1 "and" (binop-ast 1 "<" 2))) 55 | 56 | (check-equal? 57 | (parse-result-value (parse or-test '(1 "<" 2 "and" 2))) 58 | (binop-ast (binop-ast 1 "<" 2) "and" 2)) 59 | 60 | (check-equal? 61 | (parse-result-value (parse or-test '("True" "==" "False" "and" 1 "<" 2))) 62 | (binop-ast (binop-ast "True" "==" "False") "and" (binop-ast 1 "<" 2))) 63 | 64 | (check-equal? 65 | (parse-result-value (parse or-test '("not" "True" "==" "False" "or" 1 "<" 2))) 66 | (binop-ast (prefix-ast "not" (binop-ast "True" "==" "False")) "or" (binop-ast 1 "<" 2))) 67 | ) 68 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/colon-bind-shorthand.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt") 4 | 5 | (define-pegs 6 | [foo "foo"] 7 | [bar (=> (seq x:foo y:foo) 8 | (list x y))]) 9 | 10 | (module+ test 11 | (require rackunit) 12 | (check-equal? (parse-result-value (parse bar "foofoo")) 13 | '("foo" "foo"))) 14 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/core-basic-tokens.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../main.rkt") 4 | 5 | (use-literal-token-interpretation symbol-token) 6 | 7 | (define-peg t1 8 | (=> (seq "a" (seq (: r "b") "c")) 9 | 5)) 10 | 11 | (define-peg t2 12 | (=> (* (: r "a")) 13 | r)) 14 | 15 | (define-peg t3 16 | (=> (* (seq "a" (* (: r "b")))) 17 | r)) 18 | 19 | (define-peg t4 20 | (alt (=> (: a "a") a) (=> (: b "b") b))) 21 | 22 | (define-peg t5 23 | (=> (* (seq (seq (! "b") (: c (token (lambda (t) (values t #f))))) eps)) 24 | c)) 25 | 26 | (define-peg t6 27 | (alt (=> "b" '()) 28 | (=> (seq (: a "a") (: d t6)) 29 | (cons a d)))) 30 | 31 | (define-peg t7 32 | (=> (: r (seq "a" "b")) 33 | r)) 34 | 35 | (module+ test 36 | (require rackunit) 37 | 38 | (check-equal? 39 | (parse t1 '(a b c d)) 40 | (parse-result '(d) 5)) 41 | 42 | (check-equal? 43 | (parse t2 '(a a a)) 44 | (parse-result '() '(a a a))) 45 | 46 | (check-equal? 47 | (parse t3 '(a b a b b a b b b)) 48 | (parse-result '() '((b) (b b) (b b b)))) 49 | 50 | (check-equal? 51 | (parse t4 '(b)) 52 | (parse-result '() 'b)) 53 | 54 | (check-equal? 55 | (parse t5 '(a a a b)) 56 | (parse-result '(b) '(a a a))) 57 | 58 | (check-equal? 59 | (parse t6 '(a a a b)) 60 | (parse-result '() '(a a a))) 61 | 62 | ; I would like this to error, but would need static analysis rather than 63 | ; dynamic behavior to get that result without losing tail recursion on seq. 64 | (check-equal? 65 | (parse t7 '(a b)) 66 | (parse-result '() 'b)) 67 | ) 68 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/core-text.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../core.rkt") 5 | 6 | (define-peg t1 7 | (=> (seq "a" (seq (: r "b") "c")) 8 | 5)) 9 | 10 | (define-peg t2 11 | (=> (* (: r "a")) 12 | r)) 13 | 14 | (define-peg t3 15 | (=> (* (seq "a" (* (: r "b")))) 16 | r)) 17 | 18 | (define-peg t4 19 | (alt (=> (: a "a") a) (=> (: b "b") b))) 20 | 21 | (define-peg t5 22 | (=> (* (seq (seq (! "b") (: c (char (lambda (c) #t)))) eps)) 23 | c)) 24 | 25 | (define-peg t6 26 | (alt (=> "b" '()) 27 | (=> (seq (: a "a") (: d t6)) 28 | (cons a d)))) 29 | 30 | (define-peg t7 31 | (=> (: r (seq "ab" (seq "c" (* (seq (! "f") (char (lambda (c) #t))))))) 32 | r)) 33 | 34 | (module+ test 35 | (require rackunit) 36 | 37 | (check-equal? 38 | (parse-result-value (parse t1 "abcd")) 39 | 5) 40 | 41 | (check-equal? 42 | (parse-result-value (parse t2 "aaa")) 43 | '("a" "a" "a")) 44 | 45 | (check-equal? 46 | (parse-result-value (parse t3 "ababbabbb")) 47 | '(("b") ("b" "b") ("b" "b" "b"))) 48 | 49 | (check-equal? 50 | (parse-result-value (parse t4 "b")) 51 | "b") 52 | 53 | (check-equal? 54 | (parse-result-value (parse t5 "aaab")) 55 | '("a" "a" "a")) 56 | 57 | (check-equal? 58 | (parse-result-value (parse t6 "aaab")) 59 | '("a" "a" "a")) 60 | 61 | (check-equal? 62 | (parse-result-value (parse t7 "abcddf")) 63 | "abcdd") 64 | 65 | ) 66 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/define-in-let.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt" rackunit) 4 | 5 | (let () 6 | (define-peg foo "foo") 7 | (define-peg foobar (seq foo "bar")) 8 | (check-equal? (parse-result-value (parse foobar "foobar")) 9 | "bar")) 10 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/define-peg-ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "../main.rkt" 5 | "../private/forms.rkt" 6 | (for-syntax racket/base syntax/parse)) 7 | 8 | (provide define-peg-ast (struct-out ast)) 9 | 10 | (struct ast [srcloc] #:transparent) 11 | 12 | (define-for-syntax (find-parse-var-bindings stx) 13 | (syntax-parse stx 14 | #:literal-sets (peg-literals) 15 | [eps '()] 16 | [(seq e1 e2) 17 | (append (find-parse-var-bindings #'e1) 18 | (find-parse-var-bindings #'e2))] 19 | [(alt e1 e2) '()] 20 | [(? e) (find-parse-var-bindings #'e)] 21 | [(* e) (find-parse-var-bindings #'e)] 22 | [(! e) '()] 23 | [(bind x e) (list #'x)] 24 | [(=> pe e) '()] 25 | [(text t) '()] 26 | [(token f) '()] 27 | [(char f) '()] 28 | [(#%nonterm-ref name:id) '()] 29 | [(src-span v e) (find-parse-var-bindings #'e)] 30 | [_ (raise-syntax-error #f "not a core peg form" this-syntax)])) 31 | 32 | (define-syntax define-peg-ast 33 | (lambda (stx) 34 | (syntax-parse stx 35 | [(_ peg-name:id ast-name:id p:expr) 36 | (define/syntax-parse p^ (local-expand-peg #'p)) 37 | (define/syntax-parse (var ...) (find-parse-var-bindings #'p^)) 38 | #'(begin 39 | (struct ast-name ast [var ...] #:transparent) 40 | (define-peg peg-name 41 | (=> (:src-span srcloc p^) (ast-name srcloc var ...))))]))) 42 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/figure-7.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "../main.rkt") 3 | 4 | (use-literal-token-interpretation string-token) 5 | 6 | (struct binop-ast [lhs op rhs] #:transparent) 7 | 8 | (define (left-associate-binops e1 op* e*) 9 | (foldl (lambda (op e base) (binop-ast base op e)) 10 | e1 op* e*)) 11 | 12 | (define-peg term (predicate-token number?)) 13 | 14 | (define-peg arith-expr 15 | (=> (seq (: e1 term) (* (seq (: op* (alt "+" "-")) (: e* term)))) 16 | (left-associate-binops e1 op* e*))) 17 | 18 | ;; (parse arith-expr '(1 "+" 2 "-" 3)) 19 | ;; evaluates to: 20 | ;; (binop-ast (binop-ast 1 "+" 2) "-" 3) 21 | 22 | (module+ test 23 | (require rackunit) 24 | 25 | (check-equal? 26 | (parse-result-value (parse arith-expr '(1 "+" 2 "-" 3))) 27 | (binop-ast (binop-ast 1 "+" 2) "-" 3))) 28 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/leftrec-oopsla.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/load 2 | 3 | (require rackunit) 4 | 5 | ; capture compile-time errors for testing 6 | (define-syntax (test-error stx) 7 | (syntax-case stx () 8 | [(_ regexp mod) 9 | #`(check-exn 10 | regexp 11 | (lambda () 12 | #,(with-handlers ([(lambda (e) (exn:fail:syntax? e)) 13 | (lambda (e) #`(raise #,e))]) 14 | (local-expand #'mod 'top-level '()) 15 | #'#f) 16 | #t))])) 17 | 18 | ; check that expanding the submodule generates a compile-time error with the expected messagae 19 | (test-error 20 | #rx"arith-expr-leftrec: left recursion through nonterminal" 21 | (module example racket/base 22 | (require "../main.rkt") 23 | 24 | (struct binop-ast [lhs op rhs] #:transparent) 25 | 26 | (define (left-associate-binops e1 op* e*) 27 | (foldl (lambda (op e base) (binop-ast base op e)) 28 | e1 op* e*)) 29 | 30 | (define-peg term (predicate-token number?)) 31 | 32 | (define-peg arith-expr-leftrec 33 | (alt term 34 | (=> (seq (: e1 arith-expr-leftrec) (: op (alt "+" "-")) (: e2 term)) 35 | (binop-ast e1 op e2)))))) 36 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/leftrec.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/load 2 | 3 | (require rackunit) 4 | 5 | (define-syntax (test-error stx) 6 | (syntax-case stx () 7 | [(_ regexp mod) 8 | #`(check-exn 9 | regexp 10 | (lambda () 11 | #,(with-handlers ([(lambda (e) (exn:fail:syntax? e)) 12 | (lambda (e) #`(raise #,e))]) 13 | (local-expand #'mod 'top-level '()) 14 | #'#f) 15 | #t))])) 16 | 17 | 18 | (test-error 19 | #rx"arith-expr-leftrec: left recursion through nonterminal" 20 | (module ex racket/base 21 | (require "../main.rkt") 22 | 23 | ; Check that nullability information from earlier modules is available 24 | ; to later modules. 25 | (module pre racket/base 26 | (require "../main.rkt") 27 | (provide term) 28 | 29 | (define-peg term "term")) 30 | 31 | (require 'pre) 32 | 33 | (struct binop-ast [e1 op e2]) 34 | 35 | (define-peg arith-expr-leftrec 36 | (alt term 37 | (=> (seq (: e1 arith-expr-leftrec) 38 | (seq 39 | (: op (alt "+" "-")) 40 | (: e2 term))) 41 | (binop-ast e1 op e2)))))) 42 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/lift-error.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../core.rkt") 5 | 6 | (define-peg t1 7 | (=> (seq "a\n" (: r "b")) 8 | r)) 9 | 10 | (module+ test 11 | (parse t1 "a\nb")) 12 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/many-until.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt" 4 | (for-syntax racket/base syntax/parse)) 5 | 6 | (define-syntax many-until 7 | (peg-macro 8 | (lambda (stx) 9 | (syntax-parse stx 10 | [(many-until p1:expr p2:expr) 11 | ;; parse many instances of p1 until the terminator p2 is reached 12 | #'(* (seq (! p2) p1))])))) 13 | 14 | (define-peg comment 15 | (seq "#" (many-until any-char "\n"))) 16 | 17 | (define-peg string 18 | (=> (seq "\"" (many-until (: cs any-char) "\"") "\"") 19 | (list->string (map (lambda (c) (string-ref c 0)) cs)))) 20 | 21 | (define-peg whitespace " ") 22 | 23 | (define-peg line 24 | (=> (seq (? whitespace) (: e string) (? whitespace) (? comment) "\n") 25 | e)) 26 | 27 | (module+ test 28 | (require rackunit) 29 | 30 | (check-equal? (parse-result-value (parse string "\"a string\"")) 31 | "a string") 32 | 33 | (check-equal? 34 | (parse-result-value (parse line "\"a string\" # a comment\n")) 35 | "a string")) 36 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/optimization.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/load 2 | 3 | (require (for-syntax syntax/parse) racket/pretty rackunit (only-in "../main.rkt" parse parse-result?)) 4 | 5 | ; helper macros for printing the compiled code 6 | (define-for-syntax expanded #f) 7 | (define-syntax expand 8 | (syntax-parser 9 | [(_ m) 10 | (set! expanded (local-expand #'m 'top-level '())) 11 | expanded])) 12 | (define-syntax (show-expanded stx) 13 | #`(pretty-print '#,expanded)) 14 | 15 | (expand 16 | (module example racket/base 17 | (require "../main.rkt") 18 | (provide comp-op) 19 | ; the production to be optimized 20 | (define-peg comp-op 21 | (alt "==" ">=" "<=" "<" ">" "!=" "in" "not" "is")))) 22 | 23 | ; print the compiled module, showing how the production is compliled. 24 | (show-expanded) 25 | 26 | (require 'example) 27 | 28 | (for/list ([s '("==" ">=" "<=" "<" ">" "!=" "in" "not" "is")]) 29 | (check-true 30 | (parse-result? (parse comp-op s)))) 31 | 32 | (check-exn #rx"parse failed" 33 | (lambda () 34 | (parse comp-op "="))) 35 | 36 | (check-exn #rx"parse failed" 37 | (lambda () 38 | (parse comp-op "foo"))) 39 | 40 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/optional.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt") 4 | 5 | (define-peg t (=> (? (seq (: x "x") (: y "y"))) 6 | (list x y))) 7 | 8 | (module+ test 9 | (require rackunit) 10 | 11 | (check-equal? (parse-result-value (parse t "xz")) 12 | (list #f #f))) 13 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/raise-1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt") 4 | 5 | (use-literal-token-interpretation syntax-token) 6 | 7 | (struct ast [srcloc] #:transparent) 8 | 9 | ; stub `test` production 10 | (define-peg test (alt "e1" "e2")) 11 | 12 | (struct raise-ast ast [exn from] #:transparent) ; a structure with a super type, `ast` 13 | (define-peg raise 14 | (=> (:src-span srcloc 15 | (seq "raise" (? (seq (: exn test) (? (seq "from" (: from test))))))) 16 | (raise-ast srcloc exn from))) 17 | 18 | (module+ test 19 | (require rackunit racket/list syntax/srcloc) 20 | 21 | (define example-stx 22 | (syntax->list #'(raise e1 from e2))) 23 | 24 | (check-equal? 25 | (parse-result-value (parse raise example-stx)) 26 | (raise-ast 27 | (apply build-source-location example-stx) 28 | (second example-stx) 29 | (fourth example-stx)))) 30 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/raise-2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt" 4 | "define-peg-ast.rkt") 5 | 6 | (use-literal-token-interpretation syntax-token) 7 | 8 | ; stub `test` production 9 | (define-peg test (alt "e1" "e2")) 10 | 11 | (define-peg-ast raise raise-ast 12 | (seq "raise" (? (seq (: exn test) (? (seq "from" (: from test))))))) 13 | 14 | (module+ test 15 | (require rackunit racket/list syntax/srcloc) 16 | 17 | (define example-stx 18 | (syntax->list #'(raise e1 from e2))) 19 | 20 | (check-equal? 21 | (parse-result-value (parse raise example-stx)) 22 | (raise-ast 23 | (apply build-source-location example-stx) 24 | (second example-stx) 25 | (fourth example-stx)))) 26 | 27 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/return-example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | "../main.rkt" 5 | (for-syntax racket/base syntax/parse)) 6 | 7 | (module lexer-tokens racket/base 8 | (require racket/string) 9 | 10 | (provide (struct-out keyword-token) 11 | python-keyword-list) 12 | 13 | (struct keyword-token [name] #:transparent) 14 | 15 | (define python-keyword-list 16 | (string-split 17 | " 18 | False await else import pass 19 | None break except in raise 20 | True class finally is return 21 | and continue for lambda try 22 | as def from nonlocal while 23 | assert del global not with 24 | async elif if or yield 25 | + - ** * / // % @ 26 | << >> & | ^ ~ 27 | < > <= >= == != 28 | ( ) [ ] { } 29 | , : . ; @ = -> 30 | += -= *= /= //= %= @= 31 | &= |= ^= >>= <<= **= 32 | "))) 33 | 34 | (require 35 | 'lexer-tokens 36 | (for-syntax 'lexer-tokens)) 37 | 38 | (define (keyword expected-name) 39 | (lambda (t) 40 | (values 41 | (and (keyword-token? t) (equal? (keyword-token-name t) expected-name) expected-name) 42 | #f))) 43 | 44 | (define-syntax #%peg-datum 45 | (peg-macro 46 | (lambda (stx) 47 | (syntax-parse stx 48 | [(_ s:string) 49 | (unless (member (syntax-e #'s) python-keyword-list) 50 | (raise-syntax-error #f "Invalid keyword token" #'s)) 51 | #'(token (keyword 's))])))) 52 | 53 | 54 | (struct return-ast [e] #:transparent) 55 | 56 | (define-peg testlist-star-expr "True") 57 | 58 | ; with explicit `token` 59 | (define-peg p1 60 | (=> (seq (token (keyword "return")) (? (: exp testlist-star-expr))) 61 | (return-ast exp))) 62 | 63 | ; with #%peg-datum 64 | (define-peg p2 65 | (=> (seq "return" (? (: exp testlist-star-expr))) 66 | (return-ast exp))) 67 | 68 | (module+ test 69 | (require rackunit) 70 | 71 | (check-equal? 72 | (parse-result-value (parse p1 (list (keyword-token "return") (keyword-token "True")))) 73 | (return-ast "True")) 74 | 75 | (check-equal? 76 | (parse-result-value (parse p2 (list (keyword-token "return") (keyword-token "True")))) 77 | (return-ast "True"))) 78 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/sexpr.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt") 4 | 5 | (define-peg digit (alt "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")) 6 | (define-peg number (=> (: s (seq digit (* digit))) 7 | (string->number s))) 8 | (define-peg ws (* (text " "))) 9 | (define-pegs 10 | [sexpr (alt number group)] 11 | [group (=> (seq (text "(") 12 | ws 13 | (* (seq (: e sexpr) ws)) 14 | (text ")")) 15 | e)]) 16 | 17 | (module+ test 18 | (require rackunit) 19 | (check-equal? (parse-result-value (parse number "123")) 20 | 123) 21 | (check-equal? (parse-result-value (parse sexpr "123")) 22 | 123) 23 | (check-equal? (parse-result-value (parse sexpr "()")) 24 | '()) 25 | (check-equal? (parse-result-value (parse sexpr "(123)")) 26 | '(123)) 27 | (check-equal? (parse-result-value (parse sexpr "(123 456)")) 28 | '(123 456)) 29 | (check-equal? (parse-result-value (parse sexpr "(123 (456))")) 30 | '(123 (456))) 31 | (check-equal? (parse-result-value (parse sexpr "(123 ((456)))")) 32 | '(123 ((456)))) 33 | (check-equal? (parse-result-value (parse sexpr "(123 ((456) 7))")) 34 | '(123 ((456) 7))) 35 | (check-equal? (parse-result-value (parse sexpr "(123 (456) ((789) 0))")) 36 | '(123 (456) ((789) 0)))) 37 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/srcloc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | "../core.rkt" 5 | syntax/srcloc 6 | (for-syntax syntax/parse)) 7 | 8 | (define-peg t1 9 | (=> (seq "a\n" (:src-span src (: r " b\ncd"))) 10 | (list src r))) 11 | 12 | (define-syntax stx 13 | (peg-macro 14 | (syntax-parser 15 | [(_ x:id) 16 | #'(token (lambda (s) 17 | (if (eq? 'x (syntax-e s)) 18 | (values s (build-source-location s)) 19 | (values #f #f))))]))) 20 | 21 | (define-peg t2 22 | (=> (seq (stx x) (:src-span src (seq (: r1 (stx y)) (: r2 (stx z))))) 23 | (list src r1 r2))) 24 | 25 | (module+ test 26 | (require rackunit) 27 | 28 | (check-equal? 29 | (parse-result-value (parse t1 (make-text "a\n b\ncd" 'foo))) 30 | (list (srcloc 'foo 2 0 2 5) " b\ncd")) 31 | 32 | (define input (syntax->list #'(x y z))) 33 | 34 | 35 | (check-equal? 36 | (first (parse-result-value (parse t2 input))) 37 | (build-source-location (second input) (third input))) 38 | 39 | ) 40 | -------------------------------------------------------------------------------- /tests/dsls/peg/test/sugar.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../main.rkt" rackunit) 4 | 5 | (define-peg atoz 6 | (=> (: c (char-range #\a #\z)) 7 | c)) 8 | 9 | (check-equal? 10 | (parse-result-value (parse atoz "a")) 11 | "a") -------------------------------------------------------------------------------- /tests/dsls/peg/test/test-alt-str.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../main.rkt") 4 | 5 | (define-peg p1 6 | (plain-alt "==" (plain-alt ">=" (plain-alt "<=" (plain-alt "<" (plain-alt ">" (plain-alt "!=" (plain-alt "in" (seq "not" " " "in"))))))))) 7 | 8 | (define-peg p2 9 | (alt "==" ">=" "<=" "<" ">" "!=" "in" (seq "not" " " "in"))) 10 | 11 | (define times 10000000) 12 | 13 | (time 14 | (for ([n (in-range times)]) 15 | (parse p1 "in"))) 16 | 17 | (time 18 | (for ([n (in-range times)]) 19 | (parse p2 "in"))) 20 | -------------------------------------------------------------------------------- /tests/dsls/peg2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class var #:description "PEG variable") 7 | (binding-class nonterm #:description "PEG nonterminal") 8 | (extension-class peg-macro #:description "PEG macro") 9 | 10 | (nonterminal peg-el 11 | #:description "PEG expression" 12 | #:allow-extension peg-macro 13 | 14 | n:nonterm 15 | (eps) 16 | (char e:expr) 17 | (token e:expr) 18 | (alt e1:peg e2:peg) 19 | (not e:peg) 20 | 21 | (text e:racket-expr) 22 | 23 | (=> ps:peg-seq e:racket-expr) 24 | #:binding (nest ps e)) 25 | 26 | (nonterminal/nesting peg-seq (tail) 27 | #:description "PEG expression" 28 | #:allow-extension peg-macro 29 | 30 | (bind v:var ps:peg-seq) 31 | #:binding (scope (bind v) (nest ps tail)) 32 | 33 | (seq ps1:peg-seq ps2:peg-seq) 34 | #:binding (nest ps1 (nest ps2 tail)) 35 | 36 | (repeat ps:peg-seq) 37 | #:binding (nest ps tail) 38 | 39 | (src-span v:var ps:peg-seq) 40 | #:binding (scope (bind v) (nest ps tail)) 41 | 42 | pe:peg-el) 43 | 44 | (nonterminal peg 45 | ps:peg-seq 46 | #:binding (nest ps []))) 47 | 48 | (require racket/match) 49 | 50 | (check-true 51 | (match (expand-nonterminal/datum peg 52 | (=> (seq (bind a (text "a")) (bind b (=> (bind c (text "b")) 53 | (list a c)))) 54 | (list a b))) 55 | [`(=> (seq (bind a (text ,_)) (bind b (=> (bind c (text ,_)) 56 | ,_))) 57 | ,_) 58 | #t])) 59 | -------------------------------------------------------------------------------- /tests/dsls/qi-core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../../testing.rkt") 4 | 5 | (syntax-spec 6 | (nonterminal/nesting binding-floe (nested) 7 | (as v:racket-var) 8 | #:binding (scope (bind v) nested) 9 | 10 | (thread f:binding-floe ...) 11 | #:binding (nest f ... nested) 12 | 13 | f:simple-floe 14 | #:binding [f nested]) 15 | 16 | (nonterminal simple-floe 17 | v:racket-var 18 | (gen n:number) 19 | (or f:floe ...)) 20 | 21 | (nonterminal floe 22 | f:binding-floe 23 | #:binding (nest f []))) 24 | 25 | (void 26 | (expand-nonterminal/datum floe 27 | (thread (or (gen 1) (gen 2)) (as v) v))) 28 | 29 | (check-syntax-error 30 | #rx"v: not bound as racket variable" 31 | (expand-nonterminal/datum floe 32 | (thread (or (as v) v) (gen 1)))) 33 | 34 | (check-syntax-error 35 | #rx"v: not bound as racket variable" 36 | (expand-nonterminal/datum floe 37 | (thread (or (as v) (gen 1)) v))) 38 | 39 | -------------------------------------------------------------------------------- /tests/dsls/state-machine-oo/state-machine-compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide compile-machine) 4 | 5 | (require syntax/parse/define (for-syntax syntax/parse racket/list)) 6 | 7 | (define-syntax compile-machine 8 | (syntax-parser 9 | #:datum-literals (machine state on-enter) 10 | [(_ initial-state 11 | (state state-name 12 | (on-enter action ...) 13 | e ...) 14 | ... 15 | common-e ...) 16 | #:with (all-events ...) (unique-event-names #'(e ... ... common-e ...)) 17 | #'(let () 18 | (define machine% 19 | (class object% 20 | (define state #f) 21 | (define/public (set-state state%) 22 | (set! state (new state% [machine this]))) 23 | 24 | (compile-proxy-method all-events state) 25 | ... 26 | 27 | (send this set-state initial-state) 28 | (super-new))) 29 | 30 | (define common% 31 | (class object% 32 | (init-field machine) 33 | 34 | (compile-event-method common-e machine) 35 | ... 36 | 37 | (super-new))) 38 | 39 | (define state-name 40 | (class common% 41 | (inherit-field machine) 42 | 43 | action 44 | ... 45 | 46 | (compile-event-method e machine) 47 | ... 48 | 49 | (super-new))) 50 | ... 51 | 52 | (new machine%))])) 53 | 54 | (begin-for-syntax 55 | (define (unique-event-names evt-stxs) 56 | (remove-duplicates (map event-name (syntax->list evt-stxs)) 57 | bound-identifier=?)) 58 | 59 | (define (event-name e) 60 | (syntax-parse e 61 | [(on (name . _) . _) #'name]))) 62 | 63 | (define-syntax compile-proxy-method 64 | (syntax-parser 65 | [(_ name target) 66 | #'(define/public (name . args) 67 | (send/apply target name args))])) 68 | 69 | (define-syntax compile-event-method 70 | (syntax-parser 71 | #:datum-literals (on ->) 72 | [(_ (on (event-name arg ...) 73 | action ... 74 | (-> name)) 75 | machine) 76 | #'(define/public (event-name arg ...) 77 | action ... 78 | (send machine set-state name))])) -------------------------------------------------------------------------------- /tests/dsls/state-machine-oo/state-machine.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide machine state on on-enter) 4 | 5 | (require "../../../main.rkt" "state-machine-compiler.rkt") 6 | 7 | (syntax-spec 8 | (binding-class state-name) 9 | 10 | (host-interface/expression 11 | (machine #:initial-state s:state-name d:machine-decl ...) 12 | #:binding (scope (import d) ... s) 13 | #'(compile-machine s d ...)) 14 | 15 | (nonterminal/exporting machine-decl 16 | (state n:state-name 17 | e:event-decl ...) 18 | #:binding (export n) 19 | e:event-decl) 20 | 21 | (nonterminal event-decl 22 | (on-enter e:racket-expr ...) 23 | (on (evt:id arg:racket-var ...) 24 | e:racket-expr ... 25 | ((~datum ->) s:state-name)) 26 | #:binding (scope (bind arg) ... e ...))) 27 | -------------------------------------------------------------------------------- /tests/dsls/stlc-lang/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ; A little #lang wrapper around stlc. 4 | ; The first form of a program is Racket, the rest are stlc. 5 | ; The first form is intended to be used to provide stlc-defined identifiers. 6 | 7 | (require "../simply-typed-lambda-calculus.rkt") 8 | (provide (rename-out [stlc/module-begin #%module-begin]) 9 | (all-from-out "../simply-typed-lambda-calculus.rkt") 10 | (except-out (all-from-out racket) 11 | #%module-begin)) 12 | -------------------------------------------------------------------------------- /tests/dsls/stlc-lang/program.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "main.rkt" 2 | 3 | ; a program in the stlc language 4 | 5 | ;(provide x) 6 | 7 | (define x : Number 2) 8 | -------------------------------------------------------------------------------- /tests/dsls/stlc-lang/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ; testing that programs in the #lang work as expected 4 | 5 | (require "../simply-typed-lambda-calculus.rkt" 6 | "program.rkt") 7 | 8 | (module+ test 9 | (require rackunit) 10 | (check-equal? (stlc/expr x) 2)) 11 | -------------------------------------------------------------------------------- /tests/dsls/tiny-hdl/README.md: -------------------------------------------------------------------------------- 1 | An adaptation of Guillaume Savaton's TinyHDL from: 2 | 3 | https://github.com/aumouvantsillage/Tiny-HDL-Racket 4 | 5 | and 6 | 7 | http://guillaume.baierouge.fr/2020/11/08/my-first-domain-specific-language-with-racket/index.html 8 | 9 | This version implements everything except: 10 | 11 | - Checking that all ports are assigned 12 | - The #langs in blog post 6 13 | - The `use` syntax; you can just use Racket's require. 14 | 15 | Because this is a derivative work of the original TinyHDL it is available under the same MPL 2.0 license as per the LICENSE file in this directory. 16 | -------------------------------------------------------------------------------- /tests/dsls/tiny-hdl/full-adder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "hdl.rkt" "half-adder.rkt") 4 | 5 | (begin-tiny-hdl 6 | (entity full-adder ([input a] [input b] [input ci] [output s] [output co])) 7 | 8 | (architecture full-adder-arch full-adder 9 | (instance h1 half-adder-arch) 10 | (instance h2 half-adder-arch) 11 | (assign (h1 a) a) 12 | (assign (h1 b) b) 13 | (assign (h2 a) (h1 s)) 14 | (assign (h2 b) ci) 15 | (assign s (h2 s)) 16 | (assign co (or (h1 co) (h2 co))))) 17 | 18 | (print-truth-table 19 | full-adder-arch (a b ci) (s co) 20 | (#f #f #f) 21 | (#f #f #t) 22 | (#f #t #f) 23 | (#f #t #t) 24 | (#t #f #f) 25 | (#t #f #t) 26 | (#t #t #f) 27 | (#t #t #t)) -------------------------------------------------------------------------------- /tests/dsls/tiny-hdl/half-adder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide half-adder half-adder-arch) 4 | 5 | (require "hdl.rkt") 6 | 7 | (begin-tiny-hdl 8 | (entity half-adder ([input a] [input b] [output s] [output co])) 9 | 10 | (architecture half-adder-arch half-adder 11 | (assign s (xor a b)) 12 | (assign co (and a b)))) -------------------------------------------------------------------------------- /tests/dsls/typed-peg/.gitignore: -------------------------------------------------------------------------------- 1 | **/*~ 2 | **/compiled 3 | -------------------------------------------------------------------------------- /tests/dsls/typed-peg/README.md: -------------------------------------------------------------------------------- 1 | A version of the PEG DSL from `../peg` ported to Typed Racket by Michael Delmonaco. 2 | 3 | Currently it is not usable outside of the `core.rkt` module that defines the syntax because of this limitation of Typed Racket macros: https://github.com/michaelballantyne/syntax-spec/issues/24 4 | 5 | Thus, we have not ported the tests from the untyped PEG implementation. If the above issue is fixed, it should be possible. 6 | -------------------------------------------------------------------------------- /tests/dsls/typed-peg/private/forms.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide 4 | (all-defined-out) 5 | (for-syntax peg-literals)) 6 | 7 | (require 8 | (for-syntax 9 | syntax/parse)) 10 | 11 | (begin-for-syntax 12 | (define-literal-set peg-literals 13 | #:datum-literals 14 | (eps 15 | seq 16 | alt 17 | plain-alt 18 | ? 19 | * 20 | repeat 21 | ! 22 | : 23 | bind 24 | => 25 | text 26 | char 27 | token 28 | :src-span 29 | src-span 30 | #%nonterm-ref 31 | ) 32 | ())) 33 | -------------------------------------------------------------------------------- /tests/dsls/typed-peg/private/runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require 6 | racket/performance-hint 7 | racket/match 8 | syntax/srcloc) 9 | 10 | (struct failure []) 11 | (define the-failure (failure)) 12 | 13 | (struct (T) parse-result ([index : text-rep] [value : T]) #:transparent) 14 | 15 | (struct text-rep ([str : String] [source : (Union #f String)] [ix : Integer] [ln : Integer] [col : Integer]) #:transparent) 16 | 17 | (: make-text (->* (String) (String Integer Integer Integer) text-rep)) 18 | (define (make-text str [source #f] [initial-pos 0] [initial-line 1] [initial-column 0]) 19 | (text-rep str source initial-pos initial-line initial-column)) 20 | 21 | (: wrap-input (-> (Union String text-rep) text-rep)) 22 | (define (wrap-input in) 23 | (match in 24 | [(? string?) (make-text in)] 25 | [(? text-rep?) in] 26 | [_ (raise-argument-error 'parse "string?" in)])) 27 | 28 | (begin-encourage-inline 29 | (define (fail) (values the-failure (void))) 30 | 31 | (: step-input (-> Char Integer Integer Integer (values Integer Integer Integer))) 32 | (define (step-input c ix ln col) 33 | (if (char=? c #\newline) 34 | (values (+ ix 1) 35 | (+ ln 1) 36 | 0) 37 | (values (+ ix 1) 38 | ln 39 | (+ col 1)))) 40 | 41 | (: string-rt (-> String text-rep (values (Union text-rep failure) (Union String Void)))) 42 | (define (string-rt s in) 43 | (if (and (<= (+ (text-rep-ix in) (string-length s)) (string-length (text-rep-str in)))) 44 | (let loop ([ix (text-rep-ix in)] 45 | [ln (text-rep-ln in)] 46 | [col (text-rep-col in)] 47 | [s-ix 0]) 48 | (if (< s-ix (string-length s)) 49 | (let ([c (string-ref (text-rep-str in) ix)]) 50 | (if (char=? c (string-ref s s-ix)) 51 | (let-values ([(ix ln col) (step-input c ix ln col)]) 52 | (loop ix ln col (+ s-ix 1))) 53 | (fail))) 54 | (values (text-rep (text-rep-str in) (text-rep-source in) ix ln col) s))) 55 | (fail))) 56 | 57 | (: char-pred-rt (-> (-> Char Any) text-rep (values (Union text-rep failure) Void))) 58 | (define (char-pred-rt p in) 59 | (if (< (text-rep-ix in) (string-length (text-rep-str in))) 60 | (let ([c (string-ref (text-rep-str in) (text-rep-ix in))]) 61 | (if (p c) 62 | (let-values 63 | ([(ix ln col) 64 | (step-input c (text-rep-ix in) (text-rep-ln in) (text-rep-col in))]) 65 | (values (text-rep (text-rep-str in) (text-rep-source in) ix ln col) (void))) 66 | (fail))) 67 | (fail))) 68 | 69 | (: src-span-rt (All (T) (-> (-> text-rep (values text-rep T)) 70 | text-rep 71 | (values text-rep (Union #f T) (Union #f srcloc)) 72 | ))) 73 | (define (src-span-rt p in) 74 | (let ([source (text-rep-source in)] 75 | [init-pos (text-rep-ix in)] 76 | [init-ln (text-rep-ln in)] 77 | [init-col (text-rep-col in)]) 78 | (let-values ([(in^ res) (p in)]) 79 | (if (failure? in^) 80 | (values in^ #f #f) 81 | (values 82 | in^ res 83 | (srcloc source 84 | init-ln init-col 85 | init-pos (- (text-rep-ix in^) init-pos)))))))) 86 | -------------------------------------------------------------------------------- /tests/global-reference-compiler.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../testing.rkt") 4 | 5 | (syntax-spec 6 | (binding-class my-var #:reference-compiler immutable-reference-compiler) 7 | (host-interface/expression 8 | (my-let ([x:my-var e:racket-expr]) body:racket-expr ...) 9 | #:binding (scope (bind x) body ...) 10 | #'(let ([x e]) body ...))) 11 | 12 | (check-equal? 13 | (my-let ([x 2]) x) 14 | 2) 15 | 16 | (check-exn 17 | #rx"cannot mutate identifier" 18 | (lambda () 19 | (convert-compile-time-error 20 | (my-let ([x 2]) (set! x 3) x)))) 21 | 22 | (syntax-spec 23 | (binding-class dsl-var #:reference-compiler 2) 24 | (host-interface/expression 25 | (bad-let x:dsl-var e:racket-expr) 26 | #:binding (scope (bind x) e) 27 | #'(let ([x 2]) e))) 28 | 29 | (check-exn 30 | #rx"binding-class: contract violation" 31 | (lambda () 32 | (convert-compile-time-error 33 | (bad-let x x)))) 34 | -------------------------------------------------------------------------------- /tests/group-ellipsis.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; testing edge cases with ellipses and groups 4 | 5 | (require "../main.rkt") 6 | 7 | ; the test is just that this compiles 8 | (syntax-spec 9 | (nonterminal my-expr 10 | (my-let ([x:racket-var e:racket-expr] ...) body:racket-expr ...) 11 | #:binding [[e] ... (scope [(bind x)] ... [body] ...)] 12 | (my-weird-let (d1:my-exporting ...) (d2:my-exporting ...) ([x:racket-var e:racket-expr] ...) b:racket-expr) 13 | #:binding (scope [(bind x) ... (import d2) ...] (import d1) ...) 14 | (my-imporing d:my-exporting ...) 15 | #:binding (scope [(import d)] ...)) 16 | (nonterminal/exporting my-exporting 17 | (my-define-values (x:racket-var ...)) 18 | #:binding [[(export x)] ...])) 19 | 20 | ; and this---here we're making sure ...+ works just like ... for depth checking 21 | (syntax-spec 22 | (nonterminal/exporting my-def 23 | (my-def x:racket-var ...+ e:racket-expr) 24 | #:binding [(export x) ...])) 25 | -------------------------------------------------------------------------------- /tests/multi-import.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; testing the combining of multiple imports into a single import group 4 | 5 | (require "../testing.rkt" 6 | syntax/macro-testing) 7 | 8 | (syntax-spec 9 | (nonterminal/exporting defn 10 | ((~literal define) x:racket-var e:racket-expr) 11 | #:binding [(export x)]) 12 | 13 | (host-interface/expression 14 | (double-local ([d1:defn ...] [d2:defn ...]) body:racket-expr) 15 | #:binding (scope (import d1) ... (import d2) ... body) 16 | #'(compile-expr ([d1 ...] [d2 ...]) body)) 17 | 18 | (host-interface/expression 19 | (many-local ([d:defn ...] ...) body:racket-expr) 20 | ; this group is unnecessary, but we want to test the behavior of ellipsized groups with imports 21 | #:binding (scope [[[[(import d)]] ...] ...] body) 22 | #'(compile-expr ([d ...] ...) body))) 23 | 24 | (define-syntax compile-expr 25 | (syntax-parser 26 | #:literals (define) 27 | [(_ ([(define x e1) ...] ...) body) 28 | #'(let () 29 | (define x e1) 30 | ... 31 | ... 32 | body)])) 33 | 34 | (check-equal? 35 | (double-local ([(define odd? (lambda (n) (if (zero? n) #f (even? (sub1 n)))))] 36 | [(define even? (lambda (n) (or (zero? n) (odd? (sub1 n)))))]) 37 | (odd? 3)) 38 | #t) 39 | 40 | ; another test 41 | 42 | (syntax-spec 43 | (nonterminal/exporting def 44 | #:allow-extension racket-macro 45 | (mylet (d:def ...) (d2:def ...)) 46 | #:binding (scope (import d) ... (import d2) ...) 47 | (mylet2 (d:def ...) (d2:def ...)) 48 | #:binding (scope [(import d) (import d2)] ...) 49 | 50 | (mydef x:racket-var e:racket-expr) 51 | #:binding (export x) 52 | 53 | (mydefsyntax x:racket-macro e:expr) 54 | #:binding (export-syntax x e) 55 | 56 | (myexpr e:racket-expr)) 57 | (host-interface/expression 58 | (mylang d:def) 59 | #:binding (scope (import d)) 60 | #''d)) 61 | 62 | (test-case "these expand" 63 | (mylang 64 | (mylet 65 | [(myexpr 1) 66 | (mydefsyntax mydef2 (syntax-rules () [(_ x e) (mydef x e)]))] 67 | [(mydef2 x 5) 68 | (myexpr 2)])) 69 | 70 | (mylang 71 | (mylet2 72 | [(myexpr 2) 73 | (mydef2 x 5)] 74 | [(mydefsyntax mydef2 (syntax-rules () [(_ x e) (mydef x e)])) 75 | (myexpr 1)])) 76 | 77 | (void)) 78 | 79 | (test-case "these don't expand" 80 | (check-exn 81 | #rx"expected def" 82 | (lambda () 83 | (convert-compile-time-error 84 | (mylang 85 | (mylet2 86 | [(myexpr 1) 87 | (mydefsyntax mydef2 (syntax-rules () [(_ x e) (mydef x e)]))] 88 | [(mydef2 x 5) 89 | (myexpr 2)]))))) 90 | 91 | (check-exn 92 | #rx"expected def" 93 | (lambda () 94 | (convert-compile-time-error 95 | (mylang 96 | (mylet 97 | [(myexpr 2) 98 | (mydef2 x 5)] 99 | [(mydefsyntax mydef2 (syntax-rules () [(_ x e) (mydef x e)])) 100 | (myexpr 1)]))))) 101 | 102 | (void)) 103 | -------------------------------------------------------------------------------- /tests/multi-nest.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; testing the conversion from (nest x y e) to (nest x (nest y e)) 4 | 5 | (require "../testing.rkt" 6 | syntax/macro-testing) 7 | 8 | (syntax-spec 9 | (nonterminal my-expr 10 | (my-let* (b1:binding ...) 11 | (b2:binding) 12 | body:racket-expr) 13 | #:binding (nest b1 ... b2 body)) 14 | (nonterminal/nesting binding (nested) 15 | [x:racket-var e:racket-expr] 16 | #:binding (scope (bind x) nested)) 17 | (host-interface/expression 18 | (my-dsl e:my-expr) 19 | #'(compile-expr e))) 20 | 21 | (define-syntax compile-expr 22 | (syntax-parser 23 | #:literals (my-let*) 24 | [(_ (my-let* ([x1 e1] ...) 25 | ([x2 e2]) 26 | body)) 27 | #'(let* ([x1 e1] ... [x2 e2]) body)])) 28 | 29 | (check-equal? 30 | (my-dsl (my-let* ([x 1] [y x]) ([z y]) z)) 31 | 1) 32 | -------------------------------------------------------------------------------- /tests/nest-use-site-scope.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt" (for-syntax racket syntax/parse) rackunit) 4 | 5 | (syntax-spec 6 | (binding-class var) 7 | (extension-class pat-macro) 8 | 9 | (nonterminal dsl-expr 10 | v:var) 11 | 12 | (nonterminal/nesting pat (nested) 13 | #:allow-extension pat-macro 14 | 15 | v:var 16 | #:binding (scope (bind v) nested)) 17 | 18 | (host-interface/expression 19 | (my-match [p:pat e:dsl-expr]) 20 | #:binding (nest p e) 21 | #''success)) 22 | 23 | ;; I'm not sure why, but the problem didn't occur at the module level. Perhaps 24 | ;; the racket/base module-begin doing something? 25 | (let () 26 | (define-syntax m (pat-macro (syntax-rules () [(_ a) a]))) 27 | (check-equal? 28 | (my-match [(m x) x]) 29 | 'success)) 30 | 31 | (syntax-spec 32 | (nonterminal my-expr 33 | (block d:my-def ...) 34 | #:binding (scope [(import d) ...])) 35 | 36 | (nonterminal/exporting my-def 37 | ((~literal define-syntax) x:pat-macro e:expr) 38 | #:binding (export-syntax x e) 39 | ((~literal my-match) [p:pat e:dsl-expr]) 40 | #:binding (nest p e)) 41 | 42 | (host-interface/expression 43 | (eval-my-expr e:my-expr) 44 | #''success)) 45 | 46 | ; TODO: known bug with bind-syntax and nest. 47 | #;(check-equal? 48 | (eval-my-expr (block (define-syntax m (syntax-rules () [(_ a) a])) 49 | (my-match [(m x) x]))) 50 | 'success) 51 | -------------------------------------------------------------------------------- /tests/nonterminal-prop.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../main.rkt" 4 | (for-syntax syntax/parse racket/base (only-in "../private/ee-lib/main.rkt" map-transform)) 5 | rackunit 6 | syntax/macro-testing) 7 | 8 | (syntax-spec 9 | (nonterminal flow-expr 10 | (thread f:flow-expr ...+) 11 | (partition [cond:flow-expr then:flow-expr] ...) 12 | fanout 13 | (fanout n:number) 14 | (fanout n1:expr n2:number) 15 | (~>/form (fanout . _) 16 | (raise-syntax-error #f "expected one of:\n fanout\n (fanout n:number)\n (fanout n1:expr n2:number)" this-syntax))) 17 | 18 | (host-interface/expression 19 | (flow f:flow-expr) 20 | #`'#,(find-subexpr-positions #'f))) 21 | 22 | (begin-for-syntax 23 | ;; Syntax -> ListOf Syntax 24 | (define (find-subexpr-positions stx) 25 | (define subexprs '()) 26 | (map-transform 27 | (lambda (stx) 28 | (when (and (syntax? stx) (syntax-property stx 'nonterminal)) 29 | (set! subexprs (cons stx subexprs))) 30 | stx) 31 | stx) 32 | subexprs)) 33 | 34 | (check-equal? 35 | (flow (thread fanout (fanout 1) (partition [fanout (fanout 1)]))) 36 | '((thread fanout (fanout 1) (partition (fanout (fanout 1)))) 37 | (partition (fanout (fanout 1))) 38 | (fanout 1) 39 | fanout 40 | (fanout 1) 41 | fanout)) 42 | -------------------------------------------------------------------------------- /tests/props.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../testing.rkt") 4 | 5 | (syntax-spec 6 | (extension-class dsl-macro) 7 | (nonterminal dsl-expr 8 | #:allow-extension dsl-macro 9 | form 10 | (form))) 11 | 12 | 13 | (define-syntax attach-property-to-argument 14 | (dsl-macro 15 | (syntax-parser 16 | [(_ f) 17 | (syntax-property #'f 'foo 'bar)]))) 18 | 19 | (define-syntax identity-macro 20 | (dsl-macro 21 | (syntax-parser 22 | [(_ f) 23 | #'f]))) 24 | 25 | (syntax-spec 26 | (host-interface/expression 27 | (check-for-property e:dsl-expr) 28 | #`'#,(syntax-property #'e 'foo))) 29 | 30 | 31 | (check-equal? 32 | (check-for-property (attach-property-to-argument (identity-macro (form)))) 33 | 'bar) 34 | 35 | (check-equal? 36 | (check-for-property (attach-property-to-argument (identity-macro form))) 37 | 'bar) -------------------------------------------------------------------------------- /tests/racket-body.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../testing.rkt") 4 | 5 | (syntax-spec 6 | (nonterminal my-expr 7 | (my-let ([x:racket-var e:racket-expr]) body:racket-body ...+) 8 | #:binding (scope (bind x) (import body) ...)) 9 | (host-interface/expression 10 | (my-dsl e:my-expr) 11 | (syntax-parse #'e 12 | [(_ ([x e]) body ...+) 13 | #'(let ([x e]) body ...)]))) 14 | 15 | (check-equal? 16 | (my-dsl (my-let ([x 1]) x)) 17 | 1) 18 | (check-equal? 19 | (my-dsl (my-let ([x 1]) (define y x) y)) 20 | 1) 21 | (check-equal? 22 | (my-dsl (my-let ([x 1]) (define-syntax-rule (m) x) (m))) 23 | 1) 24 | -------------------------------------------------------------------------------- /tests/racket-references.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; (get-racket-referenced-vars (binding-class-id ...) e) 4 | ; returns a list of identifiers referenced in racket expressions from the specified binding classes in e. 5 | (require racket/set 6 | "../testing.rkt") 7 | 8 | (syntax-spec 9 | (binding-class a-var) 10 | (binding-class b-var) 11 | (binding-class c-var #:reference-compiler immutable-reference-compiler) 12 | (nonterminal my-expr 13 | (let/a x:a-var e:my-expr) 14 | #:binding (scope (bind x) e) 15 | (let/b x:b-var e:my-expr) 16 | #:binding (scope (bind x) e) 17 | (let/c x:c-var e:my-expr) 18 | #:binding (scope (bind x) e) 19 | (let/no-binding x:a-var e:my-expr) 20 | #:binding (scope (bind x) e) 21 | (rkt e:racket-expr)) 22 | (host-interface/expression 23 | (my-dsl e:my-expr) 24 | #'(compile-expr e))) 25 | 26 | (define-syntax compile-expr 27 | (syntax-parser 28 | #:datum-literals (let/a let/b let/c let/no-binding rkt) 29 | [(_ ((~or let/a let/b let/c) x:id e:expr)) 30 | #'(let ([x 1]) (compile-expr e))] 31 | [(_ (let/no-binding x:id e:expr)) 32 | #'(compile-expr e)] 33 | [(_ (rkt e:expr)) 34 | (define/syntax-parse (x ...) (get-racket-referenced-identifiers (a-var b-var) 35 | #'e)) 36 | #'(list 'x ...)])) 37 | 38 | (check-equal? (my-dsl (let/a x (rkt 2))) 39 | '()) 40 | (check-equal? (my-dsl (let/a x (rkt (+ x x)))) 41 | '(x)) 42 | (check-equal? (my-dsl (let/a x (rkt x))) 43 | '(x)) 44 | (check-equal? (my-dsl (let/a x (let/a y (rkt x)))) 45 | '(x)) 46 | (check-equal? (list->seteq (my-dsl (let/a x (let/a y (rkt (+ x y)))))) 47 | (seteq 'x 'y)) 48 | (check-equal? (my-dsl (let/b x (rkt (+ x x)))) 49 | '(x)) 50 | (check-equal? (my-dsl (let/c x (rkt (+ x x)))) 51 | '()) 52 | (check-equal? (list->seteq (my-dsl (let/c x 53 | (let/a y 54 | (let/b z 55 | (rkt (+ x y z))))))) 56 | (seteq 'y 'z)) 57 | (check-equal? (my-dsl (let/no-binding x (rkt (+ x x)))) 58 | '(x)) 59 | -------------------------------------------------------------------------------- /tests/reference-compiler-with-application.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ; test the behavior of a reference compiler that cares about the application case 4 | ; instead of just being a variable-like transformer. 5 | ; also make sure variable-like reference compilers support application 6 | 7 | (require "../main.rkt" 8 | (for-syntax syntax/parse racket/base) 9 | rackunit 10 | syntax/macro-testing) 11 | 12 | (begin-for-syntax 13 | ; maps each identifier to the number it's bound to 14 | (define-persistent-symbol-table number-vars)) 15 | 16 | (syntax-spec 17 | (binding-class mutable-var #:reference-compiler mutable-reference-compiler) 18 | (binding-class immutable-var #:reference-compiler immutable-reference-compiler) 19 | (binding-class weird-var 20 | #:reference-compiler (syntax-parser 21 | [x:id #'x] 22 | [(x:id . args) 23 | #`(list x `#,(length (syntax-e #'args)))])) 24 | (binding-class number-var 25 | #:reference-compiler (make-variable-like-reference-compiler 26 | (lambda (x) 27 | #`#,(symbol-table-ref number-vars x)))) 28 | (nonterminal expr 29 | (mutable-let ([x:mutable-var e:racket-expr]) body:racket-expr) 30 | #:binding (scope (bind x) body) 31 | (immutable-let ([x:immutable-var e:racket-expr]) body:racket-expr) 32 | #:binding (scope (bind x) body) 33 | (weird-let ([x:weird-var e:racket-expr]) body:racket-expr) 34 | #:binding (scope (bind x) body) 35 | (number-let ([x:number-var n:number]) body:racket-expr) 36 | #:binding (scope (bind x) body)) 37 | 38 | (host-interface/expression 39 | (expression e:expr) 40 | #'(compile-expr e))) 41 | 42 | (define-syntax compile-expr 43 | (syntax-parser 44 | [(_ ((~datum number-let) ([x n:number]) body)) 45 | (symbol-table-set! number-vars #'x (syntax-e #'n)) 46 | #'body] 47 | [(_ (_ ([x e]) body)) #'(let ([x e]) body)])) 48 | 49 | (check-equal? (expression (weird-let ([x 'foo]) x)) 'foo) 50 | (check-equal? (expression (weird-let ([x 'foo]) (x))) '(foo 0)) 51 | (check-equal? (expression (weird-let ([x 'foo]) (x 1))) '(foo 1)) 52 | (check-equal? (expression (weird-let ([x 'foo]) (x 1 2 3))) '(foo 3)) 53 | 54 | (check-equal? (expression (number-let ([x 2]) x)) 2) 55 | 56 | (check-equal? (expression (immutable-let ([x (lambda (y) y)]) (x 2))) 2) 57 | (check-equal? (expression (mutable-let ([x (lambda (y) y)]) (x 2))) 2) 58 | -------------------------------------------------------------------------------- /tests/rewrite-hygiene.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../testing.rkt" 4 | (for-syntax racket/base (except-in "../private/ee-lib/main.rkt" racket-var) syntax/parse)) 5 | 6 | (syntax-spec 7 | (binding-class dsl-name) 8 | (nonterminal dsl-expr 9 | n:dsl-name 10 | #:binding [n] 11 | 12 | (dsl-let n:dsl-name e:dsl-expr) 13 | #:binding (scope (bind n) e) 14 | 15 | ;; Introduce binding; need to ensure it does not capture references in e... 16 | (~> ((~datum a) e) 17 | #'(dsl-let x e)) 18 | 19 | ;; ... particularly references introduced by another ~>. 20 | (~> ((~datum b)) 21 | #'(dsl-let x (a x)))) 22 | 23 | (host-interface/expression 24 | (check-test e:dsl-expr) 25 | (syntax-case #'e (dsl-let) 26 | [(dsl-let b1 (dsl-let b2 r)) 27 | #`(list #,(same-binding? (compiled-from #'b1) (compiled-from #'r)) 28 | #,(same-binding? (compiled-from #'b2) (compiled-from #'r)))]))) 29 | 30 | (check-equal? 31 | (check-test (b)) 32 | (list #t #f)) 33 | 34 | -------------------------------------------------------------------------------- /tests/symbol-collections.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require "../testing.rkt") 5 | 6 | ; inserting, reading, and iterating over symbol collections 7 | (syntax-spec 8 | (binding-class my-var) 9 | (nonterminal my-expr 10 | (my-let x:my-var e:my-expr) 11 | #:binding (scope (bind x) e) 12 | (ref x:my-var ...)) 13 | (host-interface/expression 14 | (mutable e:my-expr) 15 | (define referenced-vars (local-symbol-set)) 16 | (define var-to-symbol (local-symbol-table)) 17 | (for ([x (get-referenced-vars #'e)]) 18 | (symbol-set-add! referenced-vars x) 19 | (symbol-table-set! var-to-symbol x (syntax->datum x))) 20 | (define symbols 21 | (for/list ([x (in-symbol-set referenced-vars)]) 22 | ; use an identifier returned from an interator as a key 23 | (symbol-table-ref var-to-symbol x))) 24 | #`'#,symbols) 25 | (host-interface/expression 26 | (immutable e:my-expr) 27 | (define-values (referenced-vars var-to-symbol) 28 | (for/fold ([referenced-vars (immutable-symbol-set)] 29 | [var-to-symbol (immutable-symbol-table)]) 30 | ([x (get-referenced-vars #'e)]) 31 | (values (symbol-set-add referenced-vars x) 32 | (symbol-table-set var-to-symbol x (syntax->datum x))))) 33 | (define symbols 34 | (for/list ([x (in-symbol-set referenced-vars)]) 35 | (symbol-table-ref var-to-symbol x))) 36 | #`'#,symbols)) 37 | 38 | (begin-for-syntax 39 | (define (get-referenced-vars expr) 40 | (syntax-parse expr 41 | #:datum-literals (my-let ref) 42 | [(my-let _ e) (get-referenced-vars #'e)] 43 | [(ref x ...) (attribute x)]))) 44 | 45 | (check-equal? (sort (mutable (my-let x (my-let y (ref x y)))) symbol/form (fanout . _) 14 | (raise-syntax-error #f "expected one of:\n fanout\n (fanout n:number)\n (fanout n1:expr n2:number)" this-syntax))) 15 | 16 | (host-interface/expression 17 | (flow f:flow-expr) 18 | #''f)) 19 | 20 | (flow fanout) 21 | (flow (fanout 5)) 22 | (flow (fanout 5 6)) 23 | 24 | 25 | (check-exn 26 | #rx"fanout: expected one of:\n fanout" 27 | (lambda () (convert-compile-time-error 28 | (flow (fanout 5 6 7))))) 29 | --------------------------------------------------------------------------------