diff --git a/demos/minimal-state-machine/state-machine.rkt b/demos/minimal-state-machine/state-machine.rkt index 101fbaf..1d90c0d 100644 --- a/demos/minimal-state-machine/state-machine.rkt +++ b/demos/minimal-state-machine/state-machine.rkt @@ -2,10 +2,11 @@ (provide machine state on on-enter) -(require "../../main.rkt" "state-machine-compiler.rkt") +(require "../../main.rkt") (syntax-spec (binding-class state-name) + (binding-class event-var) (host-interface/expression (machine #:initial-state s:state-name d:machine-decl ...) @@ -19,7 +20,77 @@ (nonterminal event-decl (on-enter e:racket-expr ...) - (on (evt:id arg:racket-var ...) + (on (evt:id arg:event-var ...) e:racket-expr ... ((~datum ->) s:state-name)) - #:binding (scope (bind arg) e))) \ No newline at end of file + #:binding (scope (bind arg) e))) + +(require syntax/parse/define (for-syntax syntax/parse racket/list)) + +(define-syntax compile-machine + (syntax-parser + #:datum-literals (machine state on-enter) + [(_ initial-state + (state state-name + (on-enter action ...) + e ...) + ...) + #'(with-reference-compilers ([event-var mutable-reference-compiler]) + (let () + (define machine% + (class object% + (define state #f) + (define/public (set-state state%) + (set! state (new state% [machine this]))) + + (compile-proxy-methods (e ... ...) state) + + (send this set-state initial-state) + (super-new))) + + (define state-name + (class object% + (init-field machine) + action ... + (compile-event-method e machine) ... + (super-new))) + ... + + (new machine%)))])) + +(define-syntax compile-proxy-methods + (syntax-parser + #:datum-literals (on ->) + [(_ ((on (event-name . _) . _) ...) target) + #:with (unique-event ...) + (remove-duplicates (map syntax-e (attribute event-name))) + #'(begin + (define/public (unique-event . args) + (send/apply target unique-event args)) + ...)])) + +(define-syntax compile-event-method + (syntax-parser + #:datum-literals (on ->) + [(_ (on (event-name arg ...) + action ... + (-> name)) + machine) + #'(define/public (event-name arg ...) + action ... + (send machine set-state name))])) + +(machine + #:initial-state idle + (state idle + (on-enter (displayln "pay a dollar")) + (on (dollar) + (-> paid)) + (on (select-item item) + (displayln "you need to pay before selecting an item") + (-> idle))) + (state paid + (on-enter (displayln "select an item")) + (on (select-item item) + (displayln (format "dispensing ~a" item)) + (-> idle)))) diff --git a/main.rkt b/main.rkt index 2267a55..8a0fe00 100644 --- a/main.rkt +++ b/main.rkt @@ -11,12 +11,44 @@ make-variable-like-reference-compiler + symbol-table? + mutable-symbol-table? define-persistent-symbol-table + ; deprecated define-local-symbol-table - syntax-datum? + local-symbol-table + symbol-table-set! symbol-table-ref + symbol-table-has-key? + + symbol-set? + mutable-symbol-set? + define-persistent-symbol-set + local-symbol-set + + symbol-set-add! + symbol-set-member? + + immutable-symbol-table? + immutable-symbol-table + + symbol-table-set + symbol-table-remove + + immutable-symbol-set? + immutable-symbol-set + + symbol-set-add + symbol-set-remove + symbol-set-union + symbol-set-intersection + symbol-set-subtract + + in-symbol-table + in-symbol-set + compiled-identifier=? free-identifiers alpha-equivalent?)) diff --git a/private/ee-lib/main.rkt b/private/ee-lib/main.rkt index 6ea5cd5..591c76a 100644 --- a/private/ee-lib/main.rkt +++ b/private/ee-lib/main.rkt @@ -1,6 +1,7 @@ #lang racket/base (require + racket/sequence racket/syntax syntax/parse syntax/parse/define @@ -58,23 +59,33 @@ compiled-binder? compiled-reference? + symbol-table? + mutable-symbol-table? define-persistent-symbol-table + ; deprecated define-local-symbol-table + local-symbol-table symbol-table-set! symbol-table-ref + symbol-table-has-key? + symbol-set? + mutable-symbol-set? define-persistent-symbol-set - define-local-symbol-set + local-symbol-set symbol-set-add! symbol-set-member? - immutable-symbol-table + immutable-symbol-table? + (rename-out [make-immutable-symbol-table immutable-symbol-table]) symbol-table-set + symbol-table-remove - immutable-symbol-set + immutable-symbol-set? + (rename-out [make-immutable-symbol-set immutable-symbol-set]) symbol-set-add symbol-set-remove @@ -82,6 +93,9 @@ symbol-set-intersection symbol-set-subtract + in-symbol-table + in-symbol-set + in-space module-macro @@ -479,25 +493,32 @@ (define (compiled-binder? id) (syntax-property id 'compiled-binder?)) +(struct mutable-symbol-table [id-table]) + (define-syntax-rule (define-persistent-symbol-table id) - (define-persistent-free-id-table id)) + (begin (define-persistent-free-id-table id-table) + (define id (mutable-symbol-table id-table)))) +; deprecated (define-syntax-rule (define-local-symbol-table id) - (define id (make-free-id-table))) + (define id (local-symbol-table))) + +(define (local-symbol-table) + (mutable-symbol-table (make-free-id-table))) (define/who (symbol-table-set! t id val) - (check who (lambda (v) (or (mutable-free-id-table? v) (persistent-free-id-table? v))) - #:contract "(or/c mutable-free-id-table? persistent-free-id-table?)" + (check who (lambda (v) (or (mutable-symbol-table? v))) + #:contract "mutable-symbol-table?" t) - + (check-symbol-table-new-id who t id) - - (table-set! t (compiled-from id) val)) + + (table-set! (mutable-symbol-table-id-table t) (compiled-from id) val)) (define (check-symbol-table-new-id who t id) - (when (not (or (eq? unbound (symbol-table-ref t id unbound)) + (when (not (or (not (symbol-table-has-key? t id)) ;; Hack: allow mutations for top-level keys for REPL use (top-binding? (flip-intro-scope (compiled-from id))))) (error who "table already has an entry for key"))) @@ -506,98 +527,145 @@ (error 'symbol-table-ref "no value found for key")) (define/who (symbol-table-ref t id [fail symbol-table-ref-error]) - (check who (lambda (v) (or (free-id-table? v) (persistent-free-id-table? v))) - #:contract "(or/c free-id-table? persistent-free-id-table?)" + (check who (lambda (v) (symbol-table? v)) + #:contract "symbol-table?" t) - - (table-ref t (compiled-from id) fail)) -(define-syntax-rule - (define-local-symbol-set name) - (define-local-symbol-table name)) + (table-ref (symbol-table-id-table t) (compiled-from id) fail)) + +(define (symbol-table? v) + (or (immutable-symbol-table? v) (mutable-symbol-table? v))) + +(define (symbol-table-id-table t) + (if (mutable-symbol-table? t) + (mutable-symbol-table-id-table t) + (immutable-symbol-table-id-table t))) + +(define/who (symbol-table-has-key? t id) + (check who (lambda (v) (symbol-table? v)) + #:contract "symbol-table?" + t) + (not (eq? unbound (symbol-table-ref t id unbound)))) + +(struct mutable-symbol-set [table]) + +(define (local-symbol-set . ids) + (define s (mutable-symbol-set (local-symbol-table))) + (for ([id ids]) + (symbol-set-add! s id)) + s) (define-syntax-rule (define-persistent-symbol-set name) - (define-persistent-symbol-table name)) + (begin (define-persistent-symbol-table table) + (define name (mutable-symbol-set table)))) (define/who (symbol-set-add! s id) - (check who (lambda (v) (or (mutable-free-id-table? v) (persistent-free-id-table? v))) - #:contract "(or/c mutable-free-id-table? persistent-free-id-table?)" + (check who (lambda (v) (mutable-symbol-set? v)) + #:contract "mutable-symbol-set?" s) ; check this to avoid the "key already in table" error, ; which would be confusing for a set. (unless (symbol-set-member? s id) - (symbol-table-set! s id #t))) + (symbol-table-set! (mutable-symbol-set-table s) id #t))) (define/who (symbol-set-member? s id) - (check who (lambda (v) (or (free-id-table? v) (persistent-free-id-table? v))) - #:contract "(or/c free-id-table? persistent-free-id-table?)" + (check who (lambda (v) (symbol-set? s)) + #:contract "symbol-set?" s) - (symbol-table-ref s id #f)) + (symbol-table-ref (symbol-set-table s) id #f)) + +(define (symbol-set? v) + (or (immutable-symbol-set? v) (mutable-symbol-set? v))) + +(define (symbol-set-table s) + (if (mutable-symbol-set? s) + (mutable-symbol-set-table s) + (immutable-symbol-set-table s))) + +(struct immutable-symbol-table [id-table]) -(define (immutable-symbol-table) (make-immutable-free-id-table)) +(define (make-immutable-symbol-table) + (immutable-symbol-table (make-immutable-free-id-table))) (define/who (symbol-table-set t id val) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-table? v)) + #:contract "immutable-symbol-table?" t) (check-symbol-table-new-id who t id) - (free-id-table-set t id val)) + (free-id-table-set (immutable-symbol-table-id-table t) id val)) -(define (immutable-symbol-set) (immutable-symbol-table)) +(define/who (symbol-table-remove t id val) + (check who (lambda (v) (immutable-symbol-table? v)) + #:contract "immutable-symbol-table?" + t) + (check-symbol-table-new-id who t id) + (free-id-table-remove (immutable-symbol-table-id-table t) id val)) + +(struct immutable-symbol-set [table]) + +(define (make-immutable-symbol-set . ids) + (for/fold ([s (immutable-symbol-table)]) + ([id ids]) + (symbol-set-add s id))) (define/who (symbol-set-add s id) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" s) (if (symbol-set-member? s id) s - (free-id-table-set s id #t))) + (symbol-table-set (immutable-symbol-set-table s) id #t))) (define/who (symbol-set-remove s id) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" s) - (free-id-table-remove s id)) + (symbol-table-remove (immutable-symbol-set-table s) id)) (define/who (symbol-set-union a b) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" a) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" b) (for/fold ([s a]) - ([(id v) (in-free-id-table b)] - #:when v) + ([id (in-symbol-set b)]) (symbol-set-add s id))) (define/who (symbol-set-intersection a b) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" a) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" b) (for/fold ([s (immutable-symbol-set)]) - ([(id v) (in-free-id-table a)] - #:when (and v - (free-id-table-ref b id (lambda () #f)))) + ([id (in-symbol-set a)] + #:when (symbol-set-member? s b)) (symbol-set-add s id))) (define/who (symbol-set-subtract a b) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" a) - (check who (lambda (v) (immutable-free-id-table? v)) - #:contract "immutable-free-id-table?" + (check who (lambda (v) (immutable-symbol-set? v)) + #:contract "immutable-symbol-set?" b) (for/fold ([s (immutable-symbol-set)]) - ([(id v) (in-free-id-table a)] - #:when (and v - (not (free-id-table-ref b id (lambda () #f))))) + ([id (in-symbol-set a)] + #:when (not (symbol-set-member? s b))) (symbol-set-add s id))) +(define (in-symbol-table t) + (sequence-map (lambda (id v) (values (compile-binder! id #:reuse? #t) v)) + (in-free-id-table (symbol-table-id-table t)))) + +(define (in-symbol-set s) + (sequence-map (lambda (id _) id) + (in-symbol-table (symbol-set-table s)))) + (define/who (in-space binding-space) (check who symbol? #:or-false binding-space) diff --git a/private/runtime/binding-operations.rkt b/private/runtime/binding-operations.rkt index a19c521..aece12d 100644 --- a/private/runtime/binding-operations.rkt +++ b/private/runtime/binding-operations.rkt @@ -1,7 +1,8 @@ #lang racket/base (provide free-identifiers - alpha-equivalent?) + alpha-equivalent? + (rename-out [identifier=? compiled-identifier=?])) (require racket/list racket/dict @@ -97,7 +98,7 @@ (define (alpha-equivalent? stx-a stx-b #:allow-host? [allow-host? #f]) (define bound-reference=? (alpha-equivalent?/bindings stx-a stx-b allow-host?)) (and bound-reference=? - (alpha-equivalent?/refrences stx-a stx-b bound-reference=? allow-host?))) + (alpha-equivalent?/references stx-a stx-b bound-reference=? allow-host?))) ; Syntax Syntax Boolean -> (or/c #f (Identifier Identifier -> Boolean)) ; check that the bindings of both expressions can be alpha-equivalent. @@ -127,7 +128,7 @@ ; Syntax Syntax (Identifier Identifier -> Boolean) Boolean -> Boolean ; check that the references are alpha-equivalent. -(define (alpha-equivalent?/refrences stx-a stx-b bound-reference=? allow-host?) +(define (alpha-equivalent?/references stx-a stx-b bound-reference=? allow-host?) (let loop ([stx-a stx-a] [stx-b stx-b]) (syntax-parse (list stx-a stx-b) [(~or (((~literal #%host-expression) . _) _) diff --git a/private/runtime/compile.rkt b/private/runtime/compile.rkt index 6a0c8af..6609bb9 100644 --- a/private/runtime/compile.rkt +++ b/private/runtime/compile.rkt @@ -88,7 +88,7 @@ ; wrap ctx in a pair because #f is valid as ctx but not as a syntax ; property value. - (syntax-property #`(#%host-expression #,stx) suspension-property-key (list ctx))) + (syntax-property (quasisyntax/loc stx (#%host-expression #,stx)) suspension-property-key (list ctx))) (define (suspension? stx) (not (not (and (syntax? stx) diff --git a/scribblings/main.scrbl b/scribblings/main.scrbl index c5e35fc..178c2b2 100644 --- a/scribblings/main.scrbl +++ b/scribblings/main.scrbl @@ -28,7 +28,9 @@ You might find the metalanguage useful when you both: @item{you want your DSL to be macro-extensible} ] -@include-section["tutorial.scrbl"] +@local-table-of-contents[] + +@include-section["tutorial/main.scrbl"] @include-section["reference/main.scrbl"] diff --git a/scribblings/reference/compiling.scrbl b/scribblings/reference/compiling.scrbl index 67baaad..80bc49e 100644 --- a/scribblings/reference/compiling.scrbl +++ b/scribblings/reference/compiling.scrbl @@ -1,6 +1,7 @@ #lang scribble/manual -@(require (for-label racket "../../main.rkt")) +@(require scribble/example + (for-label racket "../../main.rkt" syntax/id-table syntax/transformer)) @;----------------------- @@ -20,22 +21,126 @@ ([binding-class-id reference-compiler-expr] ...) body ...+)] +Declares which reference compiler to use when expanding DSL-bound identifiers of the specified binding classes when expanding +@racket[body]. Evaluates to @racket[body]. + @defthing[immutable-reference-compiler set!-transformer?] +Raises a syntax error when identifiers are used in @racket[set!] expressions. + @defthing[mutable-reference-compiler set!-transformer?] +Allows identifiers to be used in @racket[set!] expressions. Identifiers behave as they usually do in plain Racket. + +@defproc[(make-variable-like-reference-compiler [reference-stx (or/c syntax? (-> identifier? syntax?))] + [setter-stx (or/c syntax? (-> syntax? syntax?)) #f]) + set!-transformer?] + +Like @racket[make-variable-like-transformer]. + +If @racket[reference-stx] is syntax, replace references with it. +If @racket[reference-stx] is a procedure, apply it to the reference syntax. + +If @racket[setter-stx] is syntax, it should be syntax for a procedure which receives +the new value for the variable. +If @racket[setter-stx] is a procedure, apply it to the entire @racket[set!] expression. + +When the identifier is used in an application position, +wrap the reference with @racket[#%expression]. + +Here is an example for a @racket[match] DSL where pattern-bound variables cannot be mutated: + +@;TODO host-interface/expression and racket-expr isn't getting linked +@racketblock[ +(syntax-spec + (host-interface/expression + (match target:racket-expr c:clause ...) + #'(with-reference-compilers ([pat-var immutable-reference-compiler]) + (let ([target-pv target]) + (match-clauses target-pv c ...))))) +] + @section{Symbol tables} @defform[(define-persistent-symbol-table id)] +Defines a (mutable) symbol table for global use. For example, +if your DSL has a static type checker and you're requiring typed identifiers between modules, +you can store each identifier's type in a persistent symbol table. + +@;TODO mention how it's saved in the compiled code? + +Can only be used at the top-level of a module. + @defform[(define-local-symbol-table id)] +Defines (mutable) a symbol table for local use. + @defproc[(syntax-datum? [v any/c]) boolean?] @defproc[(symbol-table-set! [table any/c] [id identifier?] [v (or/c syntax? syntax-datum?)]) void?] +Like @racket[free-id-table-set!] + @defproc[(symbol-table-ref [table any/c] [id identifier?] [failure any/c]) any/c] +Like @racket[free-id-table-ref] + +@section{Binding Operations} + +@defproc[(compiled-identifier=? [a-id identifier?] [b-id identifier?]) boolean?] + +@;TODO run this by michael, not sure how to explain it. + +Returns @racket[#t] if the two compiled DSL identifiers correspond to the same binding, returns @racket[#f] otherwise. Similar to @racket[free-identifier=?]. + +This is the equality used by symbol tables. + +@defproc[(free-identifiers [stx syntax?] [#:allow-host? allow-host? boolean? #f]) (listof identifier?)] + +Get a DSL expression's free identifiers (deduplicated). + +Host expressions currently are not supported. + +@defproc[(alpha-equivalent? [stx-a syntax?] [stx-b syntax?] [#:allow-host? allow-host? boolean? #f]) boolean?] + +Returns @racket[#t] if the two DSL expressions are alpha-equivalent, @racket[#f] otherwise. + +Host expressions currently are not supported. + +@section{Expansion} + +@defform[(nonterminal-expander nonterminal-id) + #:contracts ([nonterminal-id identifier?])] + +Produces an expander procedure for the specified nonterminal. This procedure expands macros down to the DSL's core forms, +binds identifiers in binding positions, and can be configured to compile and rename identifiers. It does not expand host expressions. + +Expander procedure has contract @racket[(->* (syntax?) (#:should-rename? boolean?) syntax?)]. +The default behavior is not to re-compile and re-rename identifiers. To do this, pass in @racket[#:should-rename? #t]. + +Can only be used with simple non-terminals. + +@;TODO have a collection of running examples, and just require the pattern matching dsl here? + +@examples[ +(module arithmetic racket + (require syntax-spec) + (syntax-spec + (extension-class arithmetic-macro) + (nonterminal arithmetic + #:allow-extension arithmetic-macro + ((~literal +) a:arithmetic b:arithmetic) + ((~literal *) a:arithmetic b:arithmetic) + n:number)) + (define-syntax sqr + (arithmetic-macro + (syntax-rules () + [(sqr n) (* n n)]))) + (begin-for-syntax + (define local-expand-arithmetic (nonterminal-expander arithmetic)) + (displayln (local-expand-arithmetic #'(sqr 1))))) +] diff --git a/scribblings/tutorial.scrbl b/scribblings/tutorial.scrbl deleted file mode 100644 index 4e81c55..0000000 --- a/scribblings/tutorial.scrbl +++ /dev/null @@ -1,182 +0,0 @@ -#lang scribble/manual - -@(require (for-label racket "../main.rkt")) - -@title{Tutorial} - -This guide demonstrates use of syntax-spec via the case study of constructing a DSL for structuring -code as state machines. - -We will: - -@itemlist[ - @item{Define the syntax (@secref["grammar"])} - @item{Add binding rules (@secref["binding"])} - @item{Integrate Racket subexpressions (@secref["racket"])} - @item{Compile to Racket code (@secref["compilation"])} - @item{Allow macros to extend the language (@secref["macros"])} - ] - -Here's what using the DSL to define a controller for a subway turnstile looks like: - -@(racketblock - (define turnstile% - (machine - #:initial locked - - (state locked - (on (coin value) #:when (= value 0.25) - (-> unlocked)) - (on (coin value) - (-> locked))) - - (state unlocked - (on (person-enters) - (-> locked))))) - - (define ts (new turnstile%)) - (check-equal? (send ts get-state) 'locked) - (send ts coin 0.25) - (check-equal? (send ts get-state) 'unlocked)) - -The machine has two states: locked and unlocked. It reacts to two kinds of external events: a coin -with a given value being inserted, and a person passing through the turnstile. - -The @racket[machine] declaration acts as a class. Racket code interacts with the machine -by constructing an instance and calling methods corresponding to machine transitions such as @racket[coin]. -The @racket[get-state] method returns a symbol representing the current state. - -Within the machine, -Racket code is used to implement the guard on the transition to the unlocked state, which checks -that the given coin is a quarter. - - - -@section[#:tag "grammar"]{Grammar} - -The essential parts of a DSL implementation in @racket[syntax-spec] are a specification of the DSL's syntax and a compiler that transforms DSL syntax to Racket. -@; -The syntax is specified in terms of @emph{nonterminals} with associated binding rules. We'll introduce binding rules later in the tutorial. -@; -@emph{Host interface macros} tie together the specification and the DSL compiler producing a Racket macro that forms the entry point to the language implementation. - -Our initial specification with @racket[syntax-spec] supplies the grammar: - -@codeblock|{ - #lang racket - - (require syntax-spec) - - (syntax-spec - (host-interface/expression - (machine #:initial inital-state:id s:state-spec ...) - - (error 'machine "compiler not yet implemented")) - - (nonterminal state-spec - (state name:id transitions:transition-spec ...)) - - (nonterminal transition-spec - (on (event-name:id arg:id ...) action:action-spec) - (on (event-name:id arg:id ...) #:when guard:guard-expr action:action-spec)) - - (nonterminal action-spec - (goto next-state-name:id)) - - (nonterminal guard-expr - var-ref:id - n:number - (= e1:guard-expr e2:guard-expr))) -}| - - -The @racket[syntax-spec] form is the entry-point into the metalanguage. It must be used at the top-level of a module. -@; -In the example above, the language definition contains two kinds of definitions, for host interface macros and nonterminals. - -The @racket[host-interface/expression] form is used to define host interface macros that extend the language of Racket expressions. -@; -Here, it defines the @racket[machine] syntax for creating a state machine implemented as a Racket class. - -The first part of the host interface definition specifies the syntax of the host interface macro, beginning with the name of the form: @racket[machine]. -@; -The remainder of the @racket[machine] form's syntax specification describes the literal elements of the syntax and its subexpression positions. -@; -Literal elements include keywords like @racket[#:initial]. -@; -A colon-separated name like @racket[s:state-spec] indicates a subexpression position, where the first portion is the @emph{spec variable} used to name the position and the latter portion is a reference -to a nonterminal or binding class indicating the type of syntax that may appear in the subexpression. - -The remainder of the host interface declaration is compile-time Racket code. -@; -Once the DSL syntax is checked and macro-expanded according to the syntax specification, this compile-time code is responsible for compiling from the DSL to Racket. -@; -For now it's a stub. - - -@section[#:tag "binding"]{Binding} - -@subsection{Simple binding} - -@; Problem: the binding we're showing here gets referenced in a Racket subexpression, -@; not in the DSL. So we can't talk about the full story without getting into compilation, -@; and we really need `host`. -@; -@; Solution possibility: include a small language of guard expressions in the DSL definition. -@; Then later show how we can integrate with Racket instead. -@(racketblock - (binding-class local-var)) - -@(racketblock - (nonterminal event-spec - (on (evt:id) t:transition-spec) - (on (evt:id arg:local-var ...) #:when guard:guard-expr t:transition-spec) - #:binding (scope (bind arg) guard))) - - -@subsection{Definition contexts} - -@(racketblock - (binding-class state-name)) - -@(racketblock - (machine #:initial inital-state:state-name s:state-spec ...) - #:binding (scope (import s) initial-state)) - -@(racketblock - (nonterminal/exporting state-spec - (state n:state-name e:event-spec ...) - #:binding (export n))) - -@(racketblock - (nonterminal transition-spec - (-> s:state-name))) - - -@subsection{Nested binding} - -@(racketblock - (let* ([b:binding-pair ...]) e:guard-expr)) - -@(racketblock - (nonterminal binding-pair - [v:local-var e:guard-expr])) - -@(racketblock - (let* ([b:binding-pair ...]) e:guard-expr) - #:binding (nest b e)) - -@(racketblock - (nesting-nonterminal binding-pair (nested) - [v:local-var e:guard-expr] - #:binding (scope (bind v) nested))) - -@section[#:tag "racket"]{Integrating Racket Subexpressions} - -@section[#:tag "compilation"]{Compilation} - -@section[#:tag "macros"]{Macros} - -The full code for the state machine example is available at -@url{https://github.com/michaelballantyne/syntax-spec/blob/main/tests/dsls/state-machine-oo}. - diff --git a/scribblings/tutorial/basic-tutorial.scrbl b/scribblings/tutorial/basic-tutorial.scrbl new file mode 100644 index 0000000..4263a9a --- /dev/null +++ b/scribblings/tutorial/basic-tutorial.scrbl @@ -0,0 +1,593 @@ +#lang scribble/manual + +@(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../../main.rkt") + scribble/example) + +@title{Basic Tutorial: State Machine Language} + +This guide demonstrates use of syntax-spec via the case study of constructing a DSL for structuring +code as state machines. + +We will: + +@itemlist[ + @item{Define the syntax (@secref["grammar"])} + @item{Add binding rules (@secref["binding"])} + @item{Integrate Racket subexpressions (@secref["racket"])} + @item{Compile to Racket code (@secref["compilation"])} + @item{Allow macros to extend the language (@secref["macros"])} + ] + +Here's what using the DSL to define a controller for a vending machine looks like: + +@(racketblock +(define vending-machine + (machine + #:initial idle + (state idle + (on-enter (displayln "pay a dollar")) + (on (dollar) + (goto paid)) + (on (select-item item) + (displayln "you need to pay before selecting an item") + (goto idle))) + (state paid + (on-enter (displayln "select an item")) + (on (select-item item) + (displayln (format "dispensing ~a" item)) + (goto idle))))) +) + +The vending machine has two states: idle and paid. It reacts to two kinds of external events: a dollar +being inserted, and an item being selected for purchase. + +The @racket[machine] declaration acts as a class. Racket code interacts with the machine +by constructing an instance and calling methods corresponding to machine transitions such as @racket[dollar]. +The @racket[get-state] method returns a symbol representing the current state. + +Within the machine, Racket code can be run when certain states are entered or certain transitions occur. Within transitions, these actions can reference arguments to the transition event, such as @racket[item] in the @racket[select-item] event. + +@section[#:tag "grammar"]{Grammar} + +The essential parts of a DSL implementation in @racket[syntax-spec] are a specification of the DSL's syntax and a compiler that transforms DSL syntax to Racket. +@; +The syntax is specified in terms of @emph{nonterminals} with associated binding rules. We'll introduce binding rules later in the tutorial. +@; +@emph{Host interface macros} tie together the specification and the DSL compiler producing a Racket macro that forms the entry point to the language implementation. + +Our initial specification with @racket[syntax-spec] supplies the grammar: + +@codeblock|{ + #lang racket + + (require syntax-spec) + + (syntax-spec + (host-interface/expression + (machine #:initial initial-state:id s:state-spec ...) + + (error 'machine "compiler not yet implemented")) + + (nonterminal state-spec + (state name:id transitions:transition-spec ...) + (state name:id ((~datum on-enter) body:action-spec ...+) transitions:transition-spec ...)) + + (nonterminal transition-spec + (on (event-name:id arg:id ...) + action:action-spec + ... + ((~datum goto) next-state:id))) + + (nonterminal action-spec + ((~datum displayln) x:id))) +}| + +The @racket[syntax-spec] form is the entry-point into the metalanguage. It must be used at the top-level of a module. +@; +In the example above, the language definition contains two kinds of definitions, for host interface macros and nonterminals. + +The @racket[host-interface/expression] form is used to define host interface macros that extend the language of Racket expressions. +@; +Here, it defines the @racket[machine] syntax for creating a state machine implemented as a Racket class. + +The first part of the host interface definition specifies the syntax of the host interface macro, beginning with the name of the form: @racket[machine]. +@; +The remainder of the @racket[machine] form's syntax specification describes the literal elements of the syntax and its subexpression positions. +@; +Literal elements include keywords like @racket[#:initial]. +@; +A colon-separated name like @racket[s:state-spec] indicates a subexpression position, where the first portion is the @emph{spec variable} used to name the position and the latter portion is a reference +to a nonterminal or binding class indicating the type of syntax that may appear in the subexpression. + +The remainder of the host interface declaration is compile-time Racket code. +@; +Once the DSL syntax is checked and macro-expanded according to the syntax specification, this compile-time code is responsible for compiling from the DSL to Racket. +@; +For now it's a stub. + + +@section[#:tag "binding"]{Binding} + +Consider this program: + +@racketblock[ +(machine + #:initial red + (state red + (on (event x) + (goto green)) + (on (event x) + (goto red)))) +] + +Our first transition is to @racket[green], but there is no @racket[green] state. This should result in an unbound variable error. + +However, let's say our compiler translates @racket[(goto green)] to @racket[(set! state 'green)] and doesn't +produce any identifiers for @racket[green]. +Would we get an unbound reference error for @racket[green]? No! We'd just have strange behavior at runtime, or maybe +a runtime error, depending on the compiler. + +We could adjust our compiler to check for unbound state references, but syntax-spec can do it for us. syntax-spec allows us to declare +the binding and scoping rules for our language, and bindings and references will be checked before your compiler is even +invoked, so your compiler can assume the program is not only grammatically correct, but also well-bound. + +There are also several other benefits that we get by providing binding rules. We can use symbol tables to associate information with identifiers, we can allow our languages to have hygienic macros, we can compute the free identifiers of an expression, and many other identifier-related operations. We'll get more into these details later, but the point is you get a lot for free by declaring binding rules. This is why you should be excited! + +@subsection{Simple binding} + +@; Problem: the binding we're showing here gets referenced in a Racket subexpression, +@; not in the DSL. So we can't talk about the full story without getting into compilation, +@; and we really need `host`. +@; +@; Solution possibility: include a small language of guard expressions in the DSL definition. +@; Then later show how we can integrate with Racket instead. + +First, let's declare that the arguments to an action are in scope in the guard expression: + +@(racketblock + (syntax-spec + (binding-class event-var) + + ... + + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) + action:action-spec + ... + ((~datum goto) next-state:id))) + #:binding (scope (bind arg) body) + + (nonterminal action-spec + ((~datum displayln) x:event-var)))) + +We added a binding class, @racket[event-var], for an event's argument names. We also added a @racket[#:binding] declaration to transition actions to declare that the @racket[arg]s are bound in the @racket[action] expressions and this binding introduces a new scope. + +These simple binding rules behave like @racket[let]: + +@racketblock[ +(syntax-spec + (binding-class my-var) + (nonterminal my-expr + (my-let ([x:my-var e:my-expr] ...) body:my-expr) + #:binding [e (scope (bind x) body)] + x:my-var + n:number)) +] + +We could've just written @racket[(scope (bind x) body)]. syntax-spec will automatically treat @racket[e] as a reference position outside of the new scope. That's why we don't have to mention @racket[event-name] in the binding rules for transitions. Additionally, for @racket[action-spec] expressions, there is an implicit @racket[#:binding] rule generated that treats @racket[x] as a reference position. + +@subsection{Separate scope and binding forms} + +Now let's add binding rules for state names. We can't just use @racket[scope] and @racket[bind] since the binding of the state name comes from the @racket[state-spec] nonterminal, and those bindings need to be in scope throughout the entire @racket[machine] form. To use @racket[bind], we need to be able to refer to the name being bound directly. For this kind of binding structure, we use @racket[export] to export bindings from the @racket[state-spec] nonterminal and @racket[import] to import those bindings into a scope in the @racket[machine] host interface: + +@(racketblock + (binding-class state-name)) + +@(racketblock + (host-interface/expression + (machine #:initial initial-state:state-name s:state-spec ...) + #:binding (scope (import s) initial-state) + (error 'machine "compiler not yet implemented")) + + (nonterminal/exporting state-spec + (state name:state-name ((~datum on-enter) body:action-spec ...+) transition:transition-spec ...) + #:binding (export name) + + (state name:state-name transition:transition-spec ...) + #:binding (export name)) + + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) + action:action-spec + ... + ((~datum goto) next-state:state-name)))) + +We use an exporting nonterminal for @racket[state-spec], which allows us to use the @racket[export] binding rule. This binds @racket[name] in @racket[transition] and the other @racket[state-spec] forms in the body of the machine, like @racket[define] in a @racket[class] body or a @racket[block] form. + +Similar to @racket[bind] for a variable, we use @racket[import] to declare that an exporting nonterminal's bindings should be in scope for the @racket[initial-state] in the @racket[machine]. + +@subsection{Nested binding} + +There is another type of binding rule that doesn't fit into our state machine language, but you might need it when creating a different language. This is nested binding and behaves like @racket[let*], where you have a sequence of variables being defined and each one is in scope for the subsequent definitions (but not previous ones). Here is an example: + +@(racketblock + (syntax-spec + (binding-class my-var) + (nonterminal my-expr + (my-let* (b:binding-pair ...) body:my-expr) + #:binding (nest b body) + n:number + x:my-var) + (nonterminal/nesting binding-pair (nested) + [x:my-var e:my-expr] + #:binding (scope (bind x) nested)))) + +We create a nesting nonterminal for a binding pair, which has @racket[nested], which is like an argument for the nonterminal's binding rules. This represents the @tech{scope tree} of the rest of the binding rules. In this case, the scope tree gets built up sort of like @racket[foldr] on a list. + +The @deftech{scope tree} is a first-class representation of the binding structure of the program. It's not something that you explicitly work with, but it's useful to know about. Conceptually, syntax-spec uses your language's binding rules to construct this scope tree during expansion. + +From the simple nonterminal @racket[my-expr], we put the @racket[binding-pair]'s bindings in scope using @racket[nest], providing @racket[body] as the intial value of @racket[nested], like the base case value of @racket[foldr]. + +@section[#:tag "racket"]{Integrating Racket Subexpressions} + +In our state machine language, action expressions are very limited. Let's remind ourselves what the grammar for an action expression looks like: + +@(racketblock + (nonterminal action-spec + ((~datum displayln) x:event-var))) + +An action expression can only @racket[displayln] the value of a variable. What if we want something fancier, like using @racket[format] inside the @racket[displayln]? Really, it'd be ideal to be able to allow arbitrary racket expressions for the action. We can actually do that! + +@(racketblock + (syntax-spec + ... + + (nonterminal/exporting state-spec + (state name:state-name ((~datum on-enter) body:racket-expr ...+) transition:transition-spec ...) + #:binding (export name) + + (state name:state-name transition:transition-spec ...) + #:binding (export name)) + + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) + body:racket-expr + ... + ((~datum goto) next-state-name:state-name)) + #:binding (scope (bind arg) body)) + + ...)) + +Instead of using @racket[action-spec] and defining our own nonterminal for action expressions, we can just use @racket[racket-expr], which allows arbitrary racket expressions. And our @racket[event-var] identifiers will be in scope in the racket expression! We can control how references to our DSL-bound variables behave in Racket expressions and whether they're allowed at all using reference compilers, which we'll discuss in the @secref["compilation"] section. + +In addition to @racket[racket-expr], syntax-spec provides @racket[racket-var] for allowing references to Racket-defined variables in DSL expressions, and @racket[racket-macro] for allowing the language to be extended by arbitrary Racket macros. We'll talk more about macros in the @secref["macros"] section. + +@section[#:tag "compilation"]{Compilation} + +Now that we have our grammar and binding rules defined, we must write a compiler to translate a state machine program to Racket. We already have a host interface macro defined, which is the entry point to our DSL: + +@racketblock[ +(syntax-spec + ... + (host-interface/expression + (machine #:initial initial-state:state-name s:state-spec ...) + #:binding (scope (import s) initial-state) + (error 'machine "compiler not yet implemented")) + ...) +] + +However, our compiler, which performs the actual translation, is not defined. The compiler is a macro that translates our state machine language to Racket code. In our compiler, we'll translate the state machine to Racket classes using @hyperlink["https://en.wikipedia.org/wiki/State_pattern"]{the state machine pattern}. + +For example, let's imagine how we'd translate the example state machine: + +@(racketblock +(define vending-machine + (machine + #:initial idle + (state idle + (on-enter (displayln "pay a dollar")) + (on (dollar) + (goto paid)) + (on (select-item item) + (displayln "you need to pay before selecting an item") + (goto idle))) + (state paid + (on-enter (displayln "select an item")) + (on (select-item item) + (displayln (format "dispensing ~a" item)) + (goto idle))))) +) + +We'll create a class for the state machine, which acts as a context class, and a class for each state: + +@(racketblock +(let () + (define machine% + (class object% + (define state #f) + (define/public (set-state state%) + (set! state (new state% [machine this]))) + (define/public (get-state) + (send state get-state)) + + (define/public (dollar) + (send/apply state dollar)) + + (define/public (select-item item) + (send/apply state select-item item)) + + (send this set-state idle) + (super-new))) + + (define idle + (class object% + (init-field machine) + (define/public (get-state) + 'idle) + + (displayln "pay a dollar") + + (define/public (dollar) + (send machine set-state paid)) + + (define/public (select-item item) + (displayln "you need to pay before selecting an item") + (send machine set-state idle)) + (super-new))) + + (define paid + (class object% + (init-field machine) + (define/public (get-state) + 'idle) + + (displayln "select an item") + + (define/public (select-item item) + (displayln (format "dispensing ~a" item)) + (send machine set-state idle)) + (super-new))) + + (new machine%)) +) + +The @racket[machine%] class stores the current state instance and delegates to it. Each state class has methods for each defined transition. Transition actions go in the transition's method and @racket[on-enter] actions go in the class body. When a state is entered, the @racket[machine%] class creates a fresh instance of it, which runs the class body, and sets the current state to that instance. Finally, we return an instance of the machine class. + +Now Let's start to write the compiler: + +@racketblock[ +(syntax-spec + ... + (host-interface/expression + (machine #:initial initial-state:state-name s:state-spec ...) + #:binding (scope (import s) initial-state) + #'(compile-machine initial-state s ...)) + ...) + +(define-syntax compile-machine + (syntax-parser + #:datum-literals (machine state on-enter) + [(_ initial-state + (state state-name + (~optional (on-enter action ...) #:defaults ([(action 1) '()])) + e ...) + ...) + #'(with-reference-compilers ([event-var mutable-reference-compiler]) + (let () + (define machine% + (class object% + (define state #f) + (define/public (set-state state%) + (set! state (new state% [machine this]))) + (define/public (get-state) + (send state get-state)) + + (compile-proxy-methods (e ... ...) state) + + (send this set-state initial-state) + (super-new))) + + (define state-name + (class object% + (init-field machine) + (define/public (get-state) + 'state-name) + action ... + (compile-event-method e machine) ... + (super-new))) + ... + + (new machine%)))])) +] + +We defined a macro, @racket[compile-machine], which expands to something similar to what we wrote by hand above. One thing we have to do with syntax-spec is wrap the generated code in a @racket[with-reference-compilers] form. This allows us to control whether and how DSL identifiers behave in Racket expressions like actions. In our case, we use @racket[mutable-reference-compiler], which allows event arguments to be referenced and mutated. We don't specify a reference compiler for state names, so they cannot be referenced in Racket expressions. Only @racket[goto]. + +We have helpers to define the proxy methods in the @racket[machine%] class and transition methods in the state classes: + +@(racketblock +(define-syntax compile-proxy-methods + (syntax-parser + #:datum-literals (on goto) + [(_ ((on (event-name . _) . _) ...) target) + #:with (unique-event ...) + (remove-duplicates (map syntax-e (attribute event-name))) + #'(begin + (define/public (unique-event . args) + (send/apply target unique-event args)) + ...)])) + +(define-syntax compile-event-method + (syntax-parser + #:datum-literals (on goto) + [(_ (on (event-name arg ...) + action ... + (goto name)) + machine) + #'(define/public (event-name arg ...) + action ... + (send machine set-state name))])) +) + +For @racket[compile-proxy-methods], to generate one method definition for each possible transition, we gather up all the transitions in @racket[compile-machine] with that @racket[(e ... ...)], remove the duplicate transition event names, and define a proxy method for each one that delegates to the state instance, which is passed in as @racket[target]. #racket[compile-event-method] is pretty straightforward. + +One thing to note is that Racket expressions like @racket[action] in @racket[compile-event-method] get wrapped in a @racket[#%host-expression] form by syntax-spec. You can usually ignore this fact completely when writing a compiler, but if you try to inspect the contents of a Racket expression in a compiler, you'll have to account for it. + +Now we have all the pieces to run programs using state machines: + +@examples[ +#:label #f +(require racket/class + syntax-spec/tests/dsls/state-machine-for-tutorial) +(define vending-machine + (machine + #:initial idle + (state idle + (on-enter (displayln "pay a dollar")) + (on (dollar) + (goto paid)) + (on (select-item _) + (displayln "you need to pay before selecting an item") + (goto idle))) + (state paid + (on-enter (displayln "select an item")) + (on (select-item item) + (displayln (format "dispensing ~a" item)) + (goto idle))))) +(send vending-machine get-state) +(send vending-machine select-item "chips") +(send vending-machine get-state) +(send vending-machine dollar) +(send vending-machine get-state) +(send vending-machine select-item "chips") +(send vending-machine get-state) +] + +@subsection[#:tag "symbol tables"]{Symbol Tables} + +@;TODO are there significant benefits to symbol tables over free/bound id tables? + +Symbol tables and symbol sets allow us to associate information with identifiers, similar to @secref["idtable" #:doc '(lib "syntax/scribblings/syntax.scrbl")] and @secref["idset" #:doc '(lib "syntax/scribblings/syntax.scrbl")], but for DSL identifiers. + +In our language's compiler, we can use symbol set to raise an error when a state is unreachable: + +@racketblock[ +(syntax-spec + ... + (host-interface/expression + (machine #:initial initial-state:state-name s:state-spec ...) + #:binding (scope (import s) initial-state) + (check-for-inaccessible-states #'initial-state (attribute s)) + #'(compile-machine initial-state s ...)) + ...) + +(begin-for-syntax + (define (check-for-inaccessible-states initial-state-id state-specs) + (define accessible-states (get-accessible-states initial-state-id state-specs)) + (for/list ([state-spec state-specs] + #:unless (symbol-set-member? accessible-states (state-spec-name state-spec))) + (error 'machine "Inaccessible state: ~a" (syntax->datum (state-spec-name state-spec))))) + + (define (get-accessible-states initial-state-id state-specs) + (define-local-symbol-set accessible-states) + (define (find-state-spec state-name) + (findf (lambda (state-spec) + (compiled-identifier=? state-name (state-spec-name state-spec))) + state-specs)) + (define (add-reachable-states! state-name) + (unless (symbol-set-member? accessible-states state-name) + (symbol-set-add! accessible-states state-name) + (define state-spec (find-state-spec state-name)) + (for ([next-state-name (state-spec-next-state-names state-spec)]) + (add-reachable-states! next-state-name)))) + (add-reachable-states! initial-state-id) + accessible-states) + + (define (state-spec-name state-spec) + (syntax-parse state-spec + [(state name . _) #'name])) + + (define (state-spec-next-state-names state-spec) + (syntax-parse state-spec + [(state name + (~or ((~datum on-enter) . _) + ((~datum on) ev + body + ... + (goto next-state-name))) + ...) + (attribute next-state-name)]))) +] + +We build up a symbol set of accessible states with a depth-first search over the possible transitions starting from the initial state, and if we find a state that isn't accessible, we error. + +This static check runs before we generate the compiled code. Compilers may have many static analysis passes like this one, or even passes that emit an intermediate representation like ANF. There are some special considerations to be made when creating multi-pass compilers with intermediate representations in syntax-spec which are covered in @secref["multipass example"] + +@examples[ +#:label #f +(require racket/class + syntax-spec/tests/dsls/state-machine-for-tutorial) +(eval:error + (define gas-tank + (machine + #:initial full + + (state empty + (on (re-fuel) + (goto full))) + + (state full)))) +] + +We forgot to add a transition to go from full to empty. And since we start on full, there is no way to get to empty. + +@section[#:tag "macros"]{Macros} + +syntax-spec allows us to make our DSLs macro-extensible. For example, let's allow users to create macros for definining states: + +@racketblock[ +(syntax-spec + ... + (extension-class state-macro) + + (nonterminal/exporting state-spec + #:allow-extension state-macro + + ...)) + +(define-syntax-rule + (define-state-syntax name trans) + (define-extension name state-macro trans)) +] + +By adding an extension class called @racket[state-macro] and allowing @racket[state-spec] to be extended by these state macros, transformers wrapped with @racket[state-macro] can be used in @racket[state-spec] positions. syntax-spec provides @racket[define-extension] for defining these wrapped transformers. These macros will be hygienic in our DSL. Since only certain nonterminals are extensible by certain extension classes, we can control what kinds of macros can be used where. + +Now let's create a macro in our language! + +@examples[#:label #f +(require racket/class + syntax-spec/tests/dsls/state-machine-for-tutorial) +(define-state-syntax simple-state + (syntax-rules () + [(_ name [evt next] ...) + (state name + (on (evt) (goto next)) + ...)])) +(define traffic-light + (machine + #:initial red + (simple-state red [tick green]) + (simple-state green [tick yellow]) + (simple-state yellow [tick red]))) +(send traffic-light get-state) +(send traffic-light tick) +(send traffic-light get-state) +(send traffic-light tick) +(send traffic-light get-state) +(send traffic-light tick) +(send traffic-light get-state) +] + +The full code for the state machine example is available at +@url{https://github.com/michaelballantyne/syntax-spec/blob/main/tests/dsls/state-machine-for-tutorial.rkt}. + +There is also an example of using the state machine language to create a CSV browser with a GUI at @url{https://github.com/michaelballantyne/syntax-spec/blob/main/demos/minimal-state-machine/csv-browser.rkt} diff --git a/scribblings/tutorial/main.scrbl b/scribblings/tutorial/main.scrbl new file mode 100644 index 0000000..4e96f0f --- /dev/null +++ b/scribblings/tutorial/main.scrbl @@ -0,0 +1,12 @@ +#lang scribble/manual + +@(require (for-label racket)) + +@title[#:style '(toc unnumbered)]{Tutorial} + +The tutorial is broken down into illustrative examples: + +@local-table-of-contents[] + +@include-section["basic-tutorial.scrbl"] +@include-section["stlc-tutorial.scrbl"] diff --git a/scribblings/tutorial/stlc-tutorial.scrbl b/scribblings/tutorial/stlc-tutorial.scrbl new file mode 100644 index 0000000..3d16d0f --- /dev/null +++ b/scribblings/tutorial/stlc-tutorial.scrbl @@ -0,0 +1,530 @@ +#lang scribble/manual + +@(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../../main.rkt") + scribble/example) + +@title[#:tag "stlc"]{Advanced Tutorial: Simply Typed Lambda Calculus} + +This guide demonstrates advanced usage of syntax-spec via the case study of construscting a DSL for the simply typed lambda calculus. + +Here is an example program in our language: + +@racketblock[ +(let ([f (lambda ([x : Number]) x)]) + (f 1)) +] + +Let's start out with defining the grammar and binding rules for basic typed expressions: + +@racketblock[#:escape unracket +(syntax-spec + (binding-class typed-var) + (extension-class typed-macro #:binding-space stlc) + (nonterminal typed-expr + #:allow-extension typed-macro + #:binding-space stlc + + x:typed-var + n:number + + (#%lambda ([x:typed-var (~datum :) t:type] ...) body:typed-expr) + #:binding (scope (bind x) body) + (#%app fun:typed-expr arg:typed-expr ...) + + (#%let ([x:typed-var e:typed-expr] ...) body:typed-expr) + #:binding (scope (bind x) body) + + (~> (e (~datum :) t) + #'(: e t)) + (: e:typed-expr t:type) + + (~> (fun arg ...) + #'(#%app fun arg ...))) + (nonterminal type + Number + ((~datum ->) arg-type:type ... return-type:type)) + (host-interface/expression + (stlc/expr e:typed-expr) + (infer-expr-type #'e) + #'(compile-expr e)) + (host-interface/expression + (stlc/infer e:typed-expr) + (define t (infer-expr-type #'e)) + (define t-datum (type->datum t)) + #`'#,t-datum)) +] + +There are some features we've never seen here. Let's go through them one by one: + +@racketblock[ +(binding-class typed-var) +(extension-class typed-macro #:binding-space stlc) +(nonterminal typed-expr + ... + + #:binding-space stlc + + ...) +] + +Syntax-spec supports @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{binding spaces}, which allow DSL forms to have the same names as regular Racket forms like @racket[let] without shadowing them. Even DSL macros won't shadow Racket names. We will eventually write a macro for @racket[let] so we don't have to write @racket[#%let] when we use the DSL. + +@racketblock[ + +(nonterminal typed-expr + ... + + (~> (e (~datum :) t) + #'(: e t)) + (: e:typed-expr t:type) + + ...) +] + +This is called a rewrite production. We have a DSL form, @racket[:], for type annotations like @racket[(: 1 Number)]. We add a rewrite production to allow infix use like @racket[(1 : Number)] for better readability. The first part of a rewrite production is a @racketmodname[syntax/parse] pattern and the second part is the DSL form that the source syntax should transform into. The pattern cannot refer to binding classes, nonterminals, etc. + +We have another rewrite production that converts function applications to @racket[#%app] forms. It is important that this comes after the type annotation rewrite. Otherwise, infix usages would be treated as function applications. + +In general, it is a good idea to tag most forms in your grammar like @racket[#%app] to make your compiler less bug-prone. It also allows us to rely on datum literals for distinguishing between forms, which is useful when your form names are in a special binding space. + +Now let's define @racket[infer-expr-type]: + +@racketblock[ +(begin-for-syntax + (struct number-type [] #:prefab) + (struct function-type [arg-types return-type] #:prefab) + + (define-persistent-symbol-table types) + + (define (infer-expr-type e) + (syntax-parse e + [n:number (number-type)] + [x:id (get-identifier-type #'x)] + [((~datum #%lambda) ([x:id _ t] ...) body) + (define arg-types (map parse-type (attribute t))) + (for ([x (attribute x)] + [t arg-types]) + (extend-type-environment! x t)) + (define body-type (infer-expr-type #'body)) + (function-type arg-types body-type)] + [((~datum #%app) f arg ...) + (define f-type (infer-expr-type #'f)) + (match f-type + [(function-type expected-arg-types return-type) + (unless (= (length expected-arg-types) (length (attribute arg))) + (raise-syntax-error 'infer-expr-type + (format "arity error. expected ~a arguments, but got ~a" + (length expected-arg-types) + (length (attribute arg))) + this-syntax)) + (for ([expected-type expected-arg-types] + [arg (attribute arg)]) + (check-expr-type arg expected-type)) + return-type] + [_ (raise-syntax-error 'infer-expr-type + (format "type mismatch. expected a function type, but got ~a" + (type->datum f-type)) + #'f)])] + [((~datum :) e t-stx) + (define t (parse-type #'t-stx)) + (check-expr-type #'e t) + t] + [((~datum #%let) ([x e] ...) body) + (for ([x (attribute x)] + [e (attribute e)]) + (extend-type-environment! x (infer-expr-type e))) + (infer-expr-type #'body)])) + + (define (get-identifier-type x) + (symbol-table-ref types x (lambda () (raise-syntax-error #f "untyped identifier" x)))) + + (define (extend-type-environment! x t) + (void (symbol-table-ref types x (lambda () (symbol-table-set! types x t))))) + + (define (check-expr-type e expected-type) + (define actual-type (infer-expr-type e)) + (unless (equal? expected-type actual-type) + (raise-syntax-error 'infer-expr-type + (format "type mismatch. expected ~a, but got ~a" + (type->datum expected-type) + (type->datum actual-type)) + e))) + + (define (parse-type t-stx) + (syntax-parse t-stx + [(~datum Number) (number-type)] + [((~datum ->) arg-type ... return-type) + (function-type (map parse-type (attribute arg-type)) + (parse-type #'return-type))])) + + (define (type->datum t) + (match t + [(number-type) 'Number] + [(function-type arg-types return-type) + (append (list '->) + (map type->datum arg-types) + (list (type->datum return-type)))]))) +] + +We use prefab structs for our compile-time representation of types and we have a persistent symbol table mapping identifiers to types. A persistent symbol table allows information like an identifier's type to be used between modules even if the providing module has been compiled. Eventually, we'll add definitions to our language, so when type-checking a module that requires a typed identifier, we'll need the identifier's type from the persistent symbol table. + +We have to use prefab structs because persistent symbol tables can't persist non-prefab structs. The only values allowed in a symbol table are those which satisfy the @racket[syntax-datum?] predicate. + +@racket[extend-type-environment!] uses a bit of a hack. By default, symbol tables error when setting an identifier's value after it has already been set. We will end up re-inferring an expression's type later on, so we use this hack to only set the type if it isn't already set. + +@;TODO don't have a hack in the tutorial, it looks bad. add an optional flag or something. + +The rest is a typical type checker, nothing syntax-spec-specific. + +Now let's implement our compiler: + +@racketblock[#:escape unracket +(define-syntax compile-expr + (syntax-parser + [(_ n:number) #'n] + [(_ x:id) #'x] + [(_ ((~datum #%lambda) ([x:id _ _] ...) body)) + #'(lambda (x ...) (compile-expr body))] + [(_ ((~datum #%app) f arg ...)) + #'((compile-expr f) (compile-expr arg) ...)] + [(_ ((~datum :) e _)) #'(compile-expr e)] + [(_ ((~datum #%let) ([x e] ...) body)) + #'(let ([x (compile-expr e)] ...) (compile-expr body))])) +] + +Nothing special here, it's a straightforward translation to Racket. We pretty much just throw away the types. + +Finally, we can write macros for @racket[let] and @racket[lambda]: + +@racketblock[ +(define-syntax define-stlc-syntax + (syntax-parser + [(_ name:id trans:expr) + #'(define-extension name typed-macro trans)])) + +(define-stlc-syntax let + (syntax-parser + [(_ ([x e] ...) body) #'(#%let ([x e] ...) body)])) + +(define-stlc-syntax lambda + (syntax-parser + [(_ ([x (~datum :) t] ...) body) #'(#%lambda ([x : t] ...) body)])) + +(define-stlc-syntax let* + (syntax-parser + [(_ () body) #'(let () body)] + [(_ ([x:id e] binding ...) body) + #'(let ([x e]) (let* (binding ...) body))])) +] + +Right now, these don't need to be macros. But when we add definitions, We will desugar multi-body @racket[let] and @racket[lambda] expressions to single-body ones. + +Now we can run some programs: + +@examples[#:label #f +(require syntax-spec/tests/dsls/simply-typed-lambda-calculus) +(stlc/infer 1) +(stlc/expr 1) +(stlc/infer (lambda ([x : Number]) x)) +(stlc/expr (lambda ([x : Number]) x)) +] + +@section{Integrating Racket Expressions} + +Let's add arbitrary Racket expressions to our language. These can evaluate to anything, so we can't infer their types. We can require the user to annotate the type, but we shouldn't just trust that the type is correct. Instead, we should add a contract check to ensure that the annotation is accurate. + +We also need to add a contract check in the other direction, even if we don't allow arbitrary Racket expressions. Let's consider a program in our language: + +@racketblock[ +(stlc/expr (lambda ([f : (-> Number Number)] [x : Number]) (f x))) +] + +It evaluates to a function which takes in a function and a number and applies the function to a number. But @racket[stlc/expr] gives us a raw procedure that we can pass anything into! + +@racketblock[ +((stlc/expr (lambda ([f : (-> Number Number)] [x : Number]) (f x))) + "not a function" + 1) +] + +This produces a runtime type error from inside the typed code! This should be impossible. And if we allow DSL variables to be referenced in Racket expressions, we'll need to insert contract checks on references to make sure they're used properly. We can do this by creating a custom reference compiler. + +Let's do it! + +@racketblock[#:escape unracket +(syntax-spec + ... + + (nonterminal typed-expr + ... + + (rkt e:racket-expr (~datum :) t:type) + + ...) + + ... + + (host-interface/expression + (stlc/expr e:typed-expr) + (define/syntax-parse t (infer-expr-type #'e)) + #'(compile-expr/top e t)) + + ...) + +(begin-for-syntax + (define (infer-expr-type e) + (syntax-parse e + ... + + [((~datum rkt) e (~datum :) t) + (parse-type #'t)] + + ...))) + +(define-syntax compile-expr/top + (syntax-parser + [(_ e t-stx) + (define t (syntax->datum #'t-stx)) + (define/syntax-parse e^ + #'(with-reference-compilers ([typed-var typed-var-reference-compiler]) + (compile-expr e))) + #`(contract #,(type->contract-stx t) + e^ + 'stlc 'racket + #f #'e^)])) + +(begin-for-syntax + (define typed-var-reference-compiler + (make-variable-like-reference-compiler + (lambda (x) + #`(contract #,(type->contract-stx (get-identifier-type x)) + #,x + 'stlc 'racket + '#,x #'#,x)))) + + (define (type->contract-stx t) + (match t + [(number-type) #'number?] + [(function-type arg-types return-type) + (define/syntax-parse (arg-type-stx ...) (map type->contract-stx arg-types)) + (define/syntax-parse return-type-stx (type->contract-stx return-type)) + #'(-> arg-type-stx ... return-type-stx)]))) + +(define-syntax compile-expr + (syntax-parser + ... + + [(_ ((~datum rkt) e (~datum :) t)) + #`(contract #,(type->contract-stx (parse-type #'t)) + e + 'racket 'stlc + #f #'e)])) +] + +We added a new form to our language, @racket[rkt], which contains a racket expression and a type annotation. The compilation of this experssion involves a contract check to make sure the value is of the expected type. We also added a contract check in the other direction when a typed value flows out of the host interface and created a custom reference compiler using @racket[make-variable-like-reference-compiler] which inserts a contract check when a DSL variable is referenced in racket. These contract checks ensure typed values (particularly procedures) are used properly in untyped code. + +This implementation is far from efficient. Instead of generating the syntax for a contract check everywhere, we should defer to a runtime function and have the type flow into the runtime since it's a prefab struct. We should also avoid inserting a contract check every time a DSL variable is referenced in Racket and just do it once per variable. But for this tutorial, we'll keep it simple. + +Let's run some example programs now: + +@examples[#:label #f +(require syntax-spec/tests/dsls/simply-typed-lambda-calculus) +(stlc/expr + (let ([add (rkt + : (-> Number Number Number))]) + (add 1 2))) +(eval:error + (stlc/expr + (rkt "not a number" : Number))) +(eval:error + (stlc/expr + (let ([add (rkt <= : (-> Number Number Number))]) + (add 1 2)))) +(eval:error + ((stlc/expr (lambda ([f : (-> Number Number)] [x : Number]) (f x))) + "not a function" + 1)) +(eval:error + (stlc/expr + (let ([app (lambda ([f : (-> Number Number)] [x : Number]) (f x))]) + (rkt (app "not a function" 1) : Number)))) +] + +Our contract checks protect typed-untyped interactions. + +@section{Adding Definitions} + +Next, let's add definitions to our language: + +@racketblock[ +(syntax-spec + ... + (nonterminal typed-expr + ... + + (block d:typed-definition-or-expr ... e:typed-expr) + #:binding (scope (import d) e) + + ...) + + ... + + (nonterminal/exporting typed-definition-or-expr + #:allow-extension typed-macro + #:binding-space stlc + (#%define x:typed-var t:type e:typed-expr) + #:binding (export x) + (begin defn:typed-definition-or-expr ...+) + #:binding (re-export defn) + e:typed-expr) + + ... + + (host-interface/definitions + (stlc body:typed-definition-or-expr ...+) + #:binding (re-export body) + (type-check-defn-or-expr/pass1 #'(begin body ...)) + (type-check-defn-or-expr/pass2 #'(begin body ...)) + #'(compile-defn-or-expr/top (begin body ...)))) +] + +We added a new nonterminal for forms that can be used in a definition context. Since definitions inside of a @racket[begin] should spliced in to the surrounding definition context, we use the binding rule @racket[re-export], which we haven't seen yet. As the name suggests, it takes all exported names from an exporting nonterminal sub-expression and re-exports them. Here is an example of this splicing in regular Racket: + +@examples[#:label #f +(begin + (begin + (define a 1)) + (define b 2)) +(+ a b) +] + +We also added the @racket[block] form to our expression nonterminal so we can use definitions in expressions. To make the bindings from the definitions accessible within the @racket[block] form, we use @racket[scope] and @racket[import]. + +To support top-level definitions, we added a new host interface using @racket[host-interface/definitions], which we've never seen before. This defines a special type of host interface that can only be used in a definition context. This type of host interface can be used to define module-level variables that can be used with @racket[provide] and @racket[require]. Now that this is possible, it is important that we're using a persistent symbol table to store type information. + +Now let's update the rest of our code: + +@racketblock[#:escape unracket +(begin-for-syntax + (define (infer-expr-type e) + (syntax-parse e + ... + + [((~datum block) d ... e) + (type-check-defn-or-expr/pass1 #'(begin d ...)) + (type-check-defn-or-expr/pass2 #'(begin d ...)) + (infer-expr-type #'e)] + + ...)) + ... + + (define (type-check-defn-or-expr/pass1 e) + (syntax-parse e + [((~datum #%define) x:id t _) + (extend-type-environment! #'x (parse-type #'t))] + [((~datum begin) body ...) + (for ([body (attribute body)]) + (type-check-defn-or-expr/pass1 body))] + [_ (void)])) + + (define (type-check-defn-or-expr/pass2 e) + (syntax-parse e + [((~datum #%define) _ t e) + (check-expr-type #'e (parse-type #'t))] + [((~datum begin) body ...) + (for ([body (attribute body)]) + (type-check-defn-or-expr/pass2 body))] + [e (void (infer-expr-type #'e))]))) + +(define-syntax compile-expr/top + (syntax-parser + [(_ e t-stx (~optional should-skip-contract?)) + (define t (syntax->datum #'t-stx)) + (define/syntax-parse e^ + #'(with-reference-compilers ([typed-var typed-var-reference-compiler]) + (compile-expr e))) + (if (attribute should-skip-contract?) + #'e^ + #`(contract #,(type->contract-stx t) + e^ + 'stlc 'racket + #f #'e))])) + +(define-syntax compile-expr + (syntax-parser + ... + + [(_ ((~datum block) d ... e)) + #'(let () + (compile-defn-or-expr d) + ... + (compile-expr e))])) + +(define-syntax compile-defn-or-expr/top + (syntax-parser + [(_ ((~datum #%define) x:id _ body)) + #`(define x (compile-expr/top body #,(get-identifier-type #'x) #t))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr/top body) ...)] + [(_ e) + #`(compile-expr/top e #,(infer-expr-type #'e) #t)])) + +(define-syntax compile-defn-or-expr + (syntax-parser + [(_ ((~datum #%define) x:id _ body)) + #`(define x (compile-expr body))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr body) ...)] + [(_ e) + #'(compile-expr e)])) + +(define-stlc-syntax let + (syntax-parser + [(_ ([x e] ...) body) #'(#%let ([x e] ...) body)] + [(_ ([x e] ...) body ...+) #'(#%let ([x e] ...) (block body ...))])) + +(define-stlc-syntax lambda + (syntax-parser + [(_ ([x (~datum :) t] ...) body) #'(#%lambda ([x : t] ...) body)] + [(_ ([x (~datum :) t] ...) body ...+) #'(#%lambda ([x : t] ...) (block body ...))])) + +(define-stlc-syntax let* + (syntax-parser + [(_ () body) #'(let () body)] + [(_ ([x:id e] binding ...) body) + #'(let ([x e]) (let* (binding ...) body))])) + +(define-stlc-syntax define + (syntax-parser + [(_ x:id (~datum :) t e) + #'(#%define x t e)] + [(_ (f:id [arg:id (~datum :) arg-type] ...) (~datum ->) return-type body ...) + #'(#%define f (-> arg-type ... return-type) + (lambda ([arg : arg-type] ...) + body + ...))])) +] + +To type-check a group of definitions, we must take two passes. The first pass must record the type information of all defined identifiers, and the second pass checks the types of the bodies of definitions. Since mutual recursion is possible, we need the types of all identifiers before we can start checking the types of definition bodies which may reference variables before their definitions. This is a common pattern when working with mutually recursive definition contexts in general. + +When compiling top-level definitions, we must wrap expressions with @racket[with-reference-compilers], so we use @racket[compile-expr/top] from @racket[compile-defn-or-expr/top]. We added an optional flag to disable the contract check for @racket[compile-expr/top] when compiling top-level definitions since it is unnecessary. + +We also added support for multi-body @racket[let], @racket[lambda], and @racket[let*], and we added a macro around @racket[#%define] for syntactic sugar. + +Let's run it! + +@examples[#:label #f +(require syntax-spec/tests/dsls/simply-typed-lambda-calculus) +(stlc + (begin + (define two : Number + 2) + (define three : Number + 3)) + (define add : (-> Number Number Number) + (rkt + : (-> Number Number Number)))) +(stlc/expr (add two three)) +] + +@;TODO figure out why you need stlc/expr and use stlc instead + +@;TODO fix weird blame location diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt new file mode 100644 index 0000000..d969b4f --- /dev/null +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -0,0 +1,424 @@ +#lang racket/base + +; simply typed lambda calculus, featuring racket integration, dsl macros, binding spaces, +; definition contexts, re-export, top-level definitions, persistent symbol tables, +; static analysis, rewrites, and custom reference compilers. + +(provide (all-defined-out) + (for-syntax (all-defined-out)) + (for-space stlc (all-defined-out))) +(require "../../testing.rkt" + racket/contract + (for-syntax racket/match syntax/transformer)) + +(syntax-spec + (binding-class typed-var) + (extension-class typed-macro #:binding-space stlc) + (nonterminal typed-expr + #:allow-extension typed-macro + #:binding-space stlc + + x:typed-var + n:number + + (#%lambda ([x:typed-var (~datum :) t:type] ...) body:typed-expr) + #:binding (scope (bind x) body) + (#%app fun:typed-expr arg:typed-expr ...) + + (#%let ([x:typed-var e:typed-expr] ...) body:typed-expr) + #:binding (scope (bind x) body) + + ; type annotation + (~> (e (~datum :) t) + #'(: e t)) + (: e:typed-expr t:type) + + (rkt e:racket-expr (~datum :) t:type) + + (block d:typed-definition-or-expr ... e:typed-expr) + #:binding (scope (import d) e) + + ; rewrite for tagging applications + (~> (fun arg ...) + #'(#%app fun arg ...))) + (nonterminal type + (~datum Number) + ((~datum ->) arg-type:type ... return-type:type)) + (nonterminal/exporting typed-definition-or-expr + #:allow-extension typed-macro + #:binding-space stlc + (#%define x:typed-var t:type e:typed-expr) + #:binding (export x) + (begin defn:typed-definition-or-expr ...+) + #:binding (re-export defn) + e:typed-expr) + (host-interface/expression + (stlc/expr e:typed-expr) + (define/syntax-parse t (infer-expr-type #'e)) + #'(compile-expr/top e t)) + (host-interface/expression + (stlc/infer e:typed-expr) + (define t (infer-expr-type #'e)) + (define t-datum (type->datum t)) + #`'#,t-datum) + (host-interface/definitions + (stlc body:typed-definition-or-expr ...+) + #:binding (re-export body) + (type-check-defn-or-expr/pass1 #'(begin body ...)) + (type-check-defn-or-expr/pass2 #'(begin body ...)) + #'(compile-defn-or-expr/top (begin body ...)))) + +(begin-for-syntax + ; a Type is one of + (struct number-type [] #:prefab) + (struct function-type [arg-types return-type] #:prefab) + ; arg-types is a (listof Type) + + ; maps identifiers to types + (define-persistent-symbol-table types) + + ; Syntax -> Type + (define (infer-expr-type e) + (syntax-parse e + [n:number (number-type)] + [x:id (get-identifier-type #'x)] + [((~datum #%lambda) ([x:id _ t] ...) body) + (define arg-types (map parse-type (attribute t))) + (for ([x (attribute x)] + [t arg-types]) + (extend-type-environment! x t)) + (define body-type (infer-expr-type #'body)) + (function-type arg-types body-type)] + [((~datum #%app) f arg ...) + (define f-type (infer-expr-type #'f)) + (match f-type + [(function-type expected-arg-types return-type) + (unless (= (length expected-arg-types) (length (attribute arg))) + (raise-syntax-error 'infer-expr-type + (format "arity error. expected ~a arguments, but got ~a" + (length expected-arg-types) + (length (attribute arg))) + this-syntax)) + (for ([expected-type expected-arg-types] + [arg (attribute arg)]) + (check-expr-type arg expected-type)) + return-type] + [_ (raise-syntax-error 'infer-expr-type + (format "type mismatch. expected a function type, but got ~a" + (type->datum f-type)) + #'f)])] + [((~datum :) e t-stx) + (define t (parse-type #'t-stx)) + (check-expr-type #'e t) + t] + [((~datum #%let) ([x e] ...) body) + (for ([x (attribute x)] + [e (attribute e)]) + (extend-type-environment! x (infer-expr-type e))) + (infer-expr-type #'body)] + [((~datum rkt) e (~datum :) t) + (parse-type #'t)] + [((~datum block) d ... e) + (type-check-defn-or-expr/pass1 #'(begin d ...)) + (type-check-defn-or-expr/pass2 #'(begin d ...)) + (infer-expr-type #'e)])) + + ; Identifier -> Type + (define (get-identifier-type x) + (symbol-table-ref types x (lambda () (raise-syntax-error #f "untyped identifier" x)))) + + ; Identifier Type -> Void + ; Records the identifier's type. Does nothing if already recorded. + (define (extend-type-environment! x t) + (unless (symbol-table-has-key? types x) + (symbol-table-set! types x t))) + + ; Syntax Type -> Void + (define (check-expr-type e expected-type) + (define actual-type (infer-expr-type e)) + (unless (equal? expected-type actual-type) + (raise-syntax-error 'infer-expr-type + (format "type mismatch. expected ~a, but got ~a" + (type->datum expected-type) + (type->datum actual-type)) + e))) + + ; Syntax -> Void + (define (type-check-defn-or-expr/pass1 e) + (syntax-parse e + [((~datum #%define) x:id t _) + (extend-type-environment! #'x (parse-type #'t))] + [((~datum begin) body ...) + (for ([body (attribute body)]) + (type-check-defn-or-expr/pass1 body))] + [_ (void)])) + + ; Syntax -> Void + (define (type-check-defn-or-expr/pass2 e) + (syntax-parse e + [((~datum #%define) _ t e) + (check-expr-type #'e (parse-type #'t))] + [((~datum begin) body ...) + (for ([body (attribute body)]) + (type-check-defn-or-expr/pass2 body))] + [e (void (infer-expr-type #'e))])) + + ; Syntax -> Type + (define (parse-type t-stx) + (syntax-parse t-stx + [(~datum Number) (number-type)] + [((~datum ->) arg-type ... return-type) + (function-type (map parse-type (attribute arg-type)) + (parse-type #'return-type))])) + + ; Type -> any + ; converts to simple s-expression for displaying + (define (type->datum t) + (match t + [(number-type) 'Number] + [(function-type arg-types return-type) + (append (list '->) + (map type->datum arg-types) + (list (type->datum return-type)))]))) + +; inserts with-reference-compilers, and contract check +(define-syntax compile-expr/top + (syntax-parser + [(_ e t-stx (~optional should-skip-contract?)) + (define t (syntax->datum #'t-stx)) + (define/syntax-parse e^ + #'(with-reference-compilers ([typed-var typed-var-reference-compiler]) + (compile-expr e))) + (if (attribute should-skip-contract?) + #'e^ + #`(contract #,(type->contract-stx t) + e^ + 'stlc 'racket + #f #'e))])) + +(define-syntax compile-expr + (syntax-parser + [(_ n:number) #'n] + [(_ x:id) #'x] + [(_ ((~datum #%lambda) ([x:id _ _] ...) body)) + #'(lambda (x ...) (compile-expr body))] + [(_ ((~datum #%app) f arg ...)) + #'((compile-expr f) (compile-expr arg) ...)] + [(_ ((~datum :) e _)) #'(compile-expr e)] + [(_ ((~datum #%let) ([x e] ...) body)) + #'(let ([x (compile-expr e)] ...) (compile-expr body))] + [(_ ((~datum rkt) e (~datum :) t)) + #`(contract #,(type->contract-stx (parse-type #'t)) + e + 'racket 'stlc + #f #'e)] + [(_ ((~datum block) d ... e)) + #'(let () + (compile-defn-or-expr d) + ... + (compile-expr e))])) + +(begin-for-syntax + (define typed-var-reference-compiler + (make-variable-like-reference-compiler + (lambda (x) + #`(contract #,(type->contract-stx (get-identifier-type x)) + #,x + 'stlc 'racket + '#,x #'#,x)))) + + ; Type -> Syntax + ; emits syntax that specifies a contract equivalent to the given type + (define (type->contract-stx t) + (match t + [(number-type) #'number?] + [(function-type arg-types return-type) + (define/syntax-parse (arg-type-stx ...) (map type->contract-stx arg-types)) + (define/syntax-parse return-type-stx (type->contract-stx return-type)) + #'(-> arg-type-stx ... return-type-stx)]))) + +; inserts with-reference-compilers around exprs, and contract checks +(define-syntax compile-defn-or-expr/top + (syntax-parser + [(_ ((~datum #%define) x:id _ body)) + #`(define x (compile-expr/top body #,(get-identifier-type #'x) #t))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr/top body) ...)] + [(_ e) + #`(compile-expr/top e #,(infer-expr-type #'e) #t)])) + +(define-syntax compile-defn-or-expr + (syntax-parser + [(_ ((~datum #%define) x:id _ body)) + #`(define x (compile-expr body))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr body) ...)] + [(_ e) + #'(compile-expr e)])) + + +(define-syntax define-stlc-syntax + (syntax-parser + [(_ name:id trans:expr) + #'(define-extension name typed-macro trans)])) + +(define-stlc-syntax let + (syntax-parser + [(_ ([x e] ...) body) #'(#%let ([x e] ...) body)] + [(_ ([x e] ...) body ...+) #'(#%let ([x e] ...) (block body ...))])) + +(define-stlc-syntax lambda + (syntax-parser + [(_ ([x (~datum :) t] ...) body) #'(#%lambda ([x : t] ...) body)] + [(_ ([x (~datum :) t] ...) body ...+) #'(#%lambda ([x : t] ...) (block body ...))])) + +(define-stlc-syntax let* + (syntax-parser + [(_ () body) #'(let () body)] + [(_ ([x:id e] binding ...) body) + #'(let ([x e]) (let* (binding ...) body))])) + +(define-stlc-syntax define + (syntax-parser + [(_ x:id (~datum :) t e) + #'(#%define x t e)] + [(_ (f:id [arg:id (~datum :) arg-type] ...) (~datum ->) return-type body ...) + #'(#%define f (-> arg-type ... return-type) + (lambda ([arg : arg-type] ...) + body + ...))])) + +; testing + +(module+ test + (define-syntax-rule + (check-eval e v) + (check-equal? (let () (stlc e)) v)) + (define-syntax-rule + (check-infer e t) + (check-equal? (stlc/infer e) 't)) + (check-eval 1 1) + (check-eval ((lambda ([x : Number]) x) 1) 1) + (check-infer (lambda ([x : Number]) x) + (-> Number Number)) + (check-eval (let ([x 1]) x) 1) + (check-eval + (let* ([second (lambda ([x : Number] [y : Number]) y)] + [x (second 1 2)]) + x) + 2) + (check-exn + #rx"expected a function type, but got Number" + (lambda () + (convert-compile-time-error + (stlc/expr (1 2))))) + (check-exn + #rx"arity error. expected 0 arguments, but got 1" + (lambda () + (convert-compile-time-error + (stlc/expr ((lambda () 1) 2))))) + (check-exn + #rx"type mismatch. expected Number, but got \\(-> Number\\)" + (lambda () + (convert-compile-time-error + (stlc/expr ((lambda ([x : Number]) x) (lambda () 1)))))) + (check-exn + #rx"type mismatch. expected Number, but got \\(-> Number\\)" + (lambda () + (convert-compile-time-error + (stlc/expr ((lambda () 1) : Number))))) + ; racket integration + (check-infer (rkt 1 : Number) + Number) + (check-infer (rkt (lambda (x) x) : (-> Number Number)) + (-> Number Number)) + (check-eval (rkt 1 : Number) + 1) + (test-exn + "racket expr is not of the correct type" + #rx"promised: number\\?\n produced: #t" + (lambda () + (stlc/expr + (rkt #t : Number)))) + (test-exn + "racket expr is a function which breaks its contract" + #rx"promised: number\\?\n produced: #t" + (lambda () + (stlc/expr + (let ([f (rkt (lambda (x) #t) : (-> Number Number))]) + (f 1))))) + (test-exn + "typed var misused in racket expr" + #rx"expected: number\\?\n given: #t" + (lambda () + (stlc/expr + (let ([f (lambda ([x : Number]) x)]) + (rkt (f #t) : Number))))) + (test-exn + "typed function misused in racket expr" + #rx"expected: number\\?\n given: #t" + (lambda () + (stlc/expr + (let ([f (lambda ([x : Number]) x)]) + (rkt ((stlc/expr f) #t) : Number))))) + ; definitions + (check-equal? + (let () + (stlc + (define x : Number 1) + x)) + 1) + ; define at top-level + (stlc + (define one : Number 1)) + (check-eval + one + 1) + (check-equal? + (let () + (stlc + (define (id [x : Number]) -> Number + x) + (id 2))) + 2) + (check-equal? + (let () + (stlc + (define (f) -> Number + (g)) + (define (g) -> Number + 1) + (f))) + 1) + (test-equal? + "begin splices definitions" + (let () + (stlc + (begin (begin (define x : Number 1))) + x)) + 1) + ; block + (check-eval + (block 1) + 1) + (check-eval + (block 1 2) + 2) + (check-eval + (block + (define x : Number 1) + x) + 1) + ; implicit block for multi-expression let + (check-eval + (let () + (define x : Number 1) + x) + 1) + (check-eval + ((lambda () (define x : Number 1) x)) + 1) + (check-eval + (let ([add (rkt + : (-> Number Number Number))]) + (add 1 2)) + 3)) diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt new file mode 100644 index 0000000..d99b788 --- /dev/null +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -0,0 +1,209 @@ +#lang racket/base + +(provide (all-defined-out)) +(require "../../testing.rkt" + racket/class + (for-syntax racket/pretty racket/list)) + +(syntax-spec + (binding-class event-var) + (binding-class state-name) + (extension-class state-macro) + + (nonterminal/exporting state-spec + #:allow-extension state-macro + + (state name:state-name ((~datum on-enter) body:racket-expr ...+) transition:transition-spec ...) + #:binding (export name) + + (state name:state-name transition:transition-spec ...) + #:binding (export name)) + + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) + body:racket-expr + ... + ((~datum goto) next-state-name:state-name)) + #:binding (scope (bind arg) body)) + + (host-interface/expression + (machine #:initial initial-state:state-name s:state-spec ...) + #:binding (scope (import s) initial-state) + + (check-for-inaccessible-states #'initial-state (attribute s)) + #'(compile-machine initial-state s ...))) + +(begin-for-syntax + ; Identifier (listof Syntax) -> (listof Syntax) + ; Error if there is an inaccessible state + (define (check-for-inaccessible-states initial-state-id state-specs) + (define accessible-states (get-accessible-states initial-state-id state-specs)) + (for/list ([state-spec state-specs] + #:unless (symbol-set-member? accessible-states (state-spec-name state-spec))) + (error 'machine "Inaccessible state: ~a" (syntax->datum (state-spec-name state-spec))))) + + ; Identifier (listof Syntax) -> SymbolSet + (define (get-accessible-states initial-state-id state-specs) + (define accessible-states (local-symbol-set)) + (define (find-state-spec state-name) + (findf (lambda (state-spec) + (compiled-identifier=? state-name (state-spec-name state-spec))) + state-specs)) + (define (add-reachable-states! state-name) + (unless (symbol-set-member? accessible-states state-name) + (symbol-set-add! accessible-states state-name) + (define state-spec (find-state-spec state-name)) + (for ([next-state-name (state-spec-next-state-names state-spec)]) + (add-reachable-states! next-state-name)))) + (add-reachable-states! initial-state-id) + accessible-states) + + ; Syntax -> Identifier + (define (state-spec-name state-spec) + (syntax-parse state-spec + [(state name . _) #'name])) + + ; Syntax -> (listof Identifier) + ; Possible next states + (define (state-spec-next-state-names state-spec) + (syntax-parse state-spec + [(state name + (~or ((~datum on-enter) . _) + ((~datum on) ev + body + ... + (goto next-state-name))) + ...) + (attribute next-state-name)]))) + +(define-syntax compile-machine + (syntax-parser + #:datum-literals (machine state on-enter) + [(_ initial-state + (state state-name + (~optional (on-enter action ...) #:defaults ([(action 1) '()])) + e ...) + ...) + #'(with-reference-compilers ([event-var mutable-reference-compiler]) + (let () + (define machine% + (class object% + (define state #f) + (define/public (set-state state%) + (set! state (new state% [machine this]))) + (define/public (get-state) + (send state get-state)) + + (compile-proxy-methods (e ... ...) state) + + (send this set-state initial-state) + (super-new))) + + (define state-name + (class object% + (init-field machine) + (define/public (get-state) + 'state-name) + action ... + (compile-event-method e machine) ... + (super-new))) + ... + + (new machine%)))])) + +(define-syntax compile-proxy-methods + (syntax-parser + #:datum-literals (on goto) + [(_ ((on (event-name . _) . _) ...) target) + #:with (unique-event ...) + (remove-duplicates (map syntax-e (attribute event-name))) + #'(begin + (define/public (unique-event . args) + (send/apply target unique-event args)) + ...)])) + +(define-syntax compile-event-method + (syntax-parser + #:datum-literals (on goto) + [(_ (on (event-name arg ...) + action ... + (goto name)) + machine) + #'(define/public (event-name arg ...) + action ... + (send machine set-state name))])) + +(define-syntax-rule + (define-state-syntax name trans) + (define-extension name state-macro trans)) + +(module+ test + (define mchn + (machine + #:initial green + (state green + (on (good) (goto green)) + (on (bad) (goto red))) + (state red + (on (good) (goto green)) + (on (bad) (goto red))))) + (check-equal? + (send mchn get-state) + 'green) + (send mchn good) + (check-equal? + (send mchn get-state) + 'green) + (send mchn bad) + (check-equal? + (send mchn get-state) + 'red) + (check-exn + #rx"machine: Inaccessible state: unreachable" + (lambda () + (convert-compile-time-error + (machine + #:initial the-initial-state + (state the-initial-state) + (state unreachable))))) + + (define-state-syntax simple-state + (syntax-rules () + [(_ name [evt next] ...) + (state name + (on (evt) (goto next)) + ...)])) + (define traffic-light + (machine + #:initial red + (simple-state red [tick green]) + (simple-state green [tick yellow]) + (simple-state yellow [tick red]))) + (check-equal? (send traffic-light get-state) + 'red) + (send traffic-light tick) + (check-equal? (send traffic-light get-state) + 'green) + (send traffic-light tick) + (check-equal? (send traffic-light get-state) + 'yellow) + (send traffic-light tick) + (check-equal? (send traffic-light get-state) + 'red) + (let () + (define x 0) + (define y 0) + (define z 0) + (define mchn-with-actions + (machine + #:initial start + (state start + (on-enter (set! x 1)) + (on (ev) + (set! y 1) + (goto end))) + (state end + (on-enter (set! z 1))))) + (check-equal? (list x y z) '(1 0 0)) + (send mchn-with-actions ev) + (check-equal? (list x y z) '(1 1 1)))) diff --git a/tests/dsls/stlc-on-typed-racket.rkt b/tests/dsls/stlc-on-typed-racket.rkt new file mode 100644 index 0000000..48b21df --- /dev/null +++ b/tests/dsls/stlc-on-typed-racket.rkt @@ -0,0 +1,116 @@ +#lang typed/racket + +; simply typed lambda calculus hosted on typed racket. + +; simply typed lambda calculus, featuring racket integration, dsl macros, binding spaces, +; definition contexts, re-export, top-level definitions, persistent symbol tables, +; static analysis, rewrites, and custom reference compilers. + +(provide (all-defined-out) + (for-syntax (all-defined-out))) +(require (for-syntax racket/match) + "../../testing.rkt" + "simply-typed-lambda-calculus.rkt") + +(syntax-spec + (host-interface/expression + (stlc/expr e:typed-expr) + (infer-expr-type #'e) + #'(compile-expr/top e)) + (host-interface/definitions + (stlc body:typed-definition-or-expr ...+) + #:binding (re-export body) + (type-check-defn-or-expr/pass1 #'(begin body ...)) + (type-check-defn-or-expr/pass2 #'(begin body ...)) + #'(compile-defn-or-expr (begin body ...)))) + +(define-syntax compile-expr/top + (syntax-parser + [(_ e) + ; you don't need an ann around this bc the expanded code will be inferred to have the right type + #'(with-reference-compilers ([typed-var immutable-reference-compiler]) + (compile-expr e))])) + +(define-syntax compile-expr + (syntax-parser + [(_ n:number) #'n] + [(_ x:id) #'x] + [(_ ((~datum #%lambda) ([x:id _ t-stx] ...) body)) + (define ts (map parse-type (attribute t-stx))) + (define/syntax-parse (t ...) (map type->typed-racket-stx ts)) + #'(lambda ([x : t] ...) (compile-expr body))] + [(_ ((~datum #%app) f arg ...)) + #'((compile-expr f) (compile-expr arg) ...)] + [(_ ((~datum :) e _)) #'(compile-expr e)] + [(_ ((~datum #%let) ([x e] ...) body)) + (define/syntax-parse (t ...) (map (compose type->typed-racket-stx get-identifier-type) (attribute x))) + #'(let ([x : t (compile-expr e)] ...) (compile-expr body))] + [(_ ((~datum rkt) e (~datum :) t-stx)) + (define/syntax-parse t (type->typed-racket-stx (parse-type #'t-stx))) + #'(ann e t)] + [(_ ((~datum block) d ... e)) + #'(let () + (compile-defn-or-expr d) + ... + (compile-expr e))])) + +(begin-for-syntax + ; Type -> Syntax + (define (type->typed-racket-stx t) + (match t + [(number-type) #'Number] + [(function-type arg-types return-type) + (define/syntax-parse (t-arg ...) (map type->typed-racket-stx arg-types)) + (define/syntax-parse t-ret (type->typed-racket-stx return-type)) + #'(-> t-arg ... t-ret)]))) + +; inserts with-reference-compilers around exprs, and contract checks +(define-syntax compile-defn-or-expr/top + (syntax-parser + [(_ ((~datum #%define) x:id _ body)) + #`(define x (compile-expr/top body))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr/top body) ...)] + [(_ e) + #`(compile-expr/top e)])) + +(define-syntax compile-defn-or-expr + (syntax-parser + [(_ ((~datum #%define) x:id _ body)) + #`(define x (compile-expr body))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr body) ...)] + [(_ e) + #'(compile-expr e)])) + +(module+ test + (require/typed rackunit + [check-equal? (-> Any Any Any)] + [check-exn (-> Any Any Any)]) + (check-equal? + (stlc/expr (let ([x (lambda ([x : Number]) x)]) (rkt (x 1) : Number))) + 1) + ; misuse dsl value in typed racket + #;; the test doesn't work for some reason, but it currently should pass + (check-exn + #rx"given: True" + (lambda () + ((stlc/expr (lambda ([x : Number]) x)) #t))) + ; misuse typed racket function in dsl + #;; same problem as above + (stlc/expr ((rkt (lambda ([y : Boolean]) y) : (-> Number Number)) 1)) + (check-equal? + (let () + (stlc (define x : Number 1) + x)) + 1) + (check-equal? + (let () + (stlc (define (f [x : Number]) -> Number + x) + (f 1))) + 1) + (let () + (stlc (define (f [x : Number]) -> Number + x) + (f 1)))) diff --git a/tests/racket-references.rkt b/tests/racket-references.rkt new file mode 100644 index 0000000..115d851 --- /dev/null +++ b/tests/racket-references.rkt @@ -0,0 +1,70 @@ +#lang racket/base + +; (get-racket-referenced-vars (binding-class-id ...) e) +; returns a list of identifiers referenced in racket expressions from the specified binding classes in e. +(provide (for-syntax get-racket-referenced-vars)) +(require racket/set + "../testing.rkt") + +(syntax-spec + (binding-class a-var) + (binding-class b-var) + (binding-class c-var) + (nonterminal my-expr + (let/a x:a-var e:my-expr) + #:binding (scope (bind x) e) + (let/b x:b-var e:my-expr) + #:binding (scope (bind x) e) + (let/c x:c-var e:my-expr) + #:binding (scope (bind x) e) + (rkt e:racket-expr)) + (host-interface/expression + (my-dsl e:my-expr) + #'(with-reference-compilers ([c-var immutable-reference-compiler]) + (compile-expr e)))) + +(begin-for-syntax + (define current-referenced-vars (make-parameter #f)) + (define-syntax-rule (get-racket-referenced-vars [binding-class ...] e) + (parameterize ([current-referenced-vars (local-symbol-set)]) + (local-expand #`(with-reference-compilers ([binding-class recording-reference-compiler] ...) + #,e) + 'expression + '()) + (for/list ([x (in-symbol-set (current-referenced-vars))]) x))) + (define recording-reference-compiler + (make-variable-like-reference-compiler + (lambda (x) (symbol-set-add! (current-referenced-vars) x) x) + (lambda (e) + (syntax-parse e + [(set! x _) + (symbol-set-add! (current-referenced-vars) #'x) + #'x]))))) + +(define-syntax compile-expr + (syntax-parser + #:datum-literals (let/a let/b let/c rkt) + [(_ ((~or let/a let/b let/c) x:id e:expr)) + #'(let ([x 1]) (compile-expr e))] + [(_ (rkt e:expr)) + (define/syntax-parse (x ...) (get-racket-referenced-vars (a-var b-var) + #'e)) + #'(list 'x ...)])) + +(check-equal? (my-dsl (let/a x (rkt 2))) + '()) +(check-equal? (my-dsl (let/a x (rkt (+ x x)))) + '(x)) +(check-equal? (my-dsl (let/a x (let/a y (rkt x)))) + '(x)) +(check-equal? (list->seteq (my-dsl (let/a x (let/a y (rkt (+ x y)))))) + (seteq 'x 'y)) +(check-equal? (my-dsl (let/b x (rkt (+ x x)))) + '(x)) +(check-equal? (my-dsl (let/c x (rkt (+ x x)))) + '()) +(check-equal? (list->seteq (my-dsl (let/c x + (let/a y + (let/b z + (rkt (+ x y z))))))) + (seteq 'y 'z))