From 90d2b950e4b10ee4747857a8651230866f926a8a Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Mon, 6 May 2024 13:04:53 -0400 Subject: [PATCH 01/27] start writing more documentation --- scribblings/reference/compiling.scrbl | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/scribblings/reference/compiling.scrbl b/scribblings/reference/compiling.scrbl index 67baaad..e4cdab0 100644 --- a/scribblings/reference/compiling.scrbl +++ b/scribblings/reference/compiling.scrbl @@ -20,15 +20,35 @@ ([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. + +Here is an example for a @racket[match] DSL where pattern-bound variables cannot be mutated: + +@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)] +Can only be used in module context. + @defform[(define-local-symbol-table id)] @defproc[(syntax-datum? [v any/c]) boolean?] From d5fa40ae433fe3ceef27b9bfe9b07ecf3ed635e8 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 7 May 2024 15:19:04 -0400 Subject: [PATCH 02/27] finish compiling documentation, start working on tutorial --- scribblings/reference/compiling.scrbl | 81 ++++++++++++++++++++++++++- scribblings/tutorial.scrbl | 66 ++++++++++++++++++++-- 2 files changed, 139 insertions(+), 8 deletions(-) diff --git a/scribblings/reference/compiling.scrbl b/scribblings/reference/compiling.scrbl index e4cdab0..55f7cae 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)) @;----------------------- @@ -31,8 +32,25 @@ Raises a syntax error when identifiers are used in @racket[set!] expressions. 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 @@ -47,15 +65,74 @@ Here is an example for a @racket[match] DSL where pattern-bound variables cannot @defform[(define-persistent-symbol-table id)] -Can only be used in module context. +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[(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 index 4e81c55..c7bde5e 100644 --- a/scribblings/tutorial.scrbl +++ b/scribblings/tutorial.scrbl @@ -89,6 +89,8 @@ Our initial specification with @racket[syntax-spec] supplies the grammar: (= e1:guard-expr e2:guard-expr))) }| +@;TODO should goto be ->? + The @racket[syntax-spec] form is the entry-point into the metalanguage. It must be used at the top-level of a module. @; @@ -116,6 +118,33 @@ For now it's a stub. @section[#:tag "binding"]{Binding} +Consider this program: + +@racketblock[ +(machine + #:initial red + (state red + (on (event x) #:when (= y 10) + (-> green)) + (on (event x) + (-> red)))) +] + +In the guard @racket[(= y 10)], the @racket[y] is unbound. +Additionally, our first transition is to @racket[green], but there is no @racket[green] state. +Our compiled code will end up containing an unbound variable reference for @racket[y], so Racket's +expander will raise an error. + +However, let's say our compiler translates @racket[(-> green)] to @racket[(set! state 'green)] and generally doesn't +produce any identifiers for @racket[green], +and we changed the guard to @racket[(= x 10)] instead of @racket[(= y 10)], so there's no unbound reference to @racket[y]. +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. + @subsection{Simple binding} @; Problem: the binding we're showing here gets referenced in a Racket subexpression, @@ -124,15 +153,39 @@ For now it's a stub. @; @; 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)) + +First, let's declare that the arguments to an action are in scope in the guard expression: @(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))) + (syntax-spec + (binding-class event-var) + ... + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) action:action-spec) + #:binding (scope (bind arg)) + (on (event-name:id arg:event-var ...) #:when guard:guard-expr action:action-spec) + #:binding (scope (bind arg) guard)) + ... + (nonterminal guard-expr + var-ref:event-var + n:number + (= e1:guard-expr e2:guard-expr)))) + +We added a binding class, @racket[event-var], for an event's argument names. We also added a @racket[#:binding] declaration to guarded transitions to declare that the @racket[arg]s are bound in the @racket[guard] expression and this binding introduces a new scope. Although there are no reference positions in a non-guarded transition, we still need to declare the binding rule. Otherwise, by default, syntax-spec will assume that the @racket[arg] is a reference position, which will cause @racket[arg] to be unbound. + +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 (group 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[action] or @racket[event-name] in the binding rules for transitions. @subsection{Definition contexts} @@ -180,3 +233,4 @@ For now it's a stub. 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}. +@;TODO demonstrate symbol tables by doing an arity check on actions? From 1b58f5ee799690fdab33339ef50c2f3e85e99c27 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 9 May 2024 23:55:17 -0400 Subject: [PATCH 03/27] work on tutorial --- scribblings/tutorial.scrbl | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/scribblings/tutorial.scrbl b/scribblings/tutorial.scrbl index c7bde5e..1523258 100644 --- a/scribblings/tutorial.scrbl +++ b/scribblings/tutorial.scrbl @@ -26,13 +26,13 @@ Here's what using the DSL to define a controller for a subway turnstile looks li (state locked (on (coin value) #:when (= value 0.25) - (-> unlocked)) + (goto unlocked)) (on (coin value) - (-> locked))) + (goto locked))) (state unlocked (on (person-enters) - (-> locked))))) + (goto locked))))) (define ts (new turnstile%)) (check-equal? (send ts get-state) 'locked) @@ -89,9 +89,6 @@ Our initial specification with @racket[syntax-spec] supplies the grammar: (= e1:guard-expr e2:guard-expr))) }| -@;TODO should goto be ->? - - 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. @@ -125,9 +122,9 @@ Consider this program: #:initial red (state red (on (event x) #:when (= y 10) - (-> green)) + (goto green)) (on (event x) - (-> red)))) + (goto red)))) ] In the guard @racket[(= y 10)], the @racket[y] is unbound. @@ -135,7 +132,7 @@ Additionally, our first transition is to @racket[green], but there is no @racket Our compiled code will end up containing an unbound variable reference for @racket[y], so Racket's expander will raise an error. -However, let's say our compiler translates @racket[(-> green)] to @racket[(set! state 'green)] and generally doesn't +However, let's say our compiler translates @racket[(goto green)] to @racket[(set! state 'green)] and doesn't produce any identifiers for @racket[green], and we changed the guard to @racket[(= x 10)] instead of @racket[(= y 10)], so there's no unbound reference to @racket[y]. Would we get an unbound reference error for @racket[green]? No! We'd just have strange behavior at runtime, or maybe @@ -171,7 +168,7 @@ First, let's declare that the arguments to an action are in scope in the guard e n:number (= e1:guard-expr e2:guard-expr)))) -We added a binding class, @racket[event-var], for an event's argument names. We also added a @racket[#:binding] declaration to guarded transitions to declare that the @racket[arg]s are bound in the @racket[guard] expression and this binding introduces a new scope. Although there are no reference positions in a non-guarded transition, we still need to declare the binding rule. Otherwise, by default, syntax-spec will assume that the @racket[arg] is a reference position, which will cause @racket[arg] to be unbound. +We added a binding class, @racket[event-var], for an event's argument names. We also added a @racket[#:binding] declaration to guarded transitions to declare that the @racket[arg]s are bound in the @racket[guard] expression and this binding introduces a new scope. Although there are no reference positions in a non-guarded transition, we still need to declare the binding rule. Otherwise, by default, syntax-spec will assume that the @racket[arg] is a reference position, which will cause @racket[arg] to be unbound. When we don't include any binding rule for a production at all, a default binding rule is implicitly generated which treats all forms as reference positions. These simple binding rules behave like @racket[let]: @@ -189,22 +186,24 @@ We could've just written @racket[(scope (bind x) body)]. syntax-spec will automa @subsection{Definition contexts} +Now let's add binding rules for state names. We can't just use @racket[scope] and @racket[bind] since the binding for state names is not like @racket[let]. It's more like @racket[define] where you can have mutual recursion. For that kind of binding structure, we use @racket[export] and @racket[import]: + @(racketblock (binding-class state-name)) @(racketblock - (machine #:initial inital-state:state-name s:state-spec ...) - #:binding (scope (import s) initial-state)) + (host-interface/expression + (machine #:initial inital-state:state-name s:state-spec ...) + #:binding (scope (import s) initial-state) + (error 'machine "compiler not yet implemented")) -@(racketblock (nonterminal/exporting state-spec - (state n:state-name e:event-spec ...) - #:binding (export n))) + (state name:state-name transition:transition-spec ...) + #:binding (export name))) -@(racketblock - (nonterminal transition-spec - (-> s:state-name))) +We use an exporting nonterminal for @racket[state-spec], which allows us to use the @racket[export] binding rule for mutually recursive definitions. 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. +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} From af25d2f696a6e90d4168d3cbebfbc82e1dfe2fc6 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 14 May 2024 00:33:33 -0400 Subject: [PATCH 04/27] =?UTF-8?q?nesting=20tutorial,=20start=20compiler,?= =?UTF-8?q?=20compiled-id=3D=3F?= --- main.rkt | 1 + private/runtime/binding-operations.rkt | 3 +- scribblings/tutorial.scrbl | 61 ++++++++++--- tests/dsls/state-machine-for-tutorial.rkt | 104 ++++++++++++++++++++++ 4 files changed, 155 insertions(+), 14 deletions(-) create mode 100644 tests/dsls/state-machine-for-tutorial.rkt diff --git a/main.rkt b/main.rkt index 2267a55..b21e855 100644 --- a/main.rkt +++ b/main.rkt @@ -17,6 +17,7 @@ symbol-table-set! symbol-table-ref + compiled-identifier=? free-identifiers alpha-equivalent?)) diff --git a/private/runtime/binding-operations.rkt b/private/runtime/binding-operations.rkt index a19c521..029e5cf 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 diff --git a/scribblings/tutorial.scrbl b/scribblings/tutorial.scrbl index 1523258..a4c9fcf 100644 --- a/scribblings/tutorial.scrbl +++ b/scribblings/tutorial.scrbl @@ -69,7 +69,7 @@ Our initial specification with @racket[syntax-spec] supplies the grammar: (syntax-spec (host-interface/expression - (machine #:initial inital-state:id s:state-spec ...) + (machine #:initial initial-state:id s:state-spec ...) (error 'machine "compiler not yet implemented")) @@ -142,6 +142,8 @@ We could adjust our compiler to check for unbound state references, but syntax-s 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, it allows 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, @@ -193,13 +195,16 @@ Now let's add binding rules for state names. We can't just use @racket[scope] an @(racketblock (host-interface/expression - (machine #:initial inital-state:state-name s:state-spec ...) + (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 transition:transition-spec ...) - #:binding (export name))) + #:binding (export name)) + + (nonterminal action-spec + (goto next-state-name:state-name))) We use an exporting nonterminal for @racket[state-spec], which allows us to use the @racket[export] binding rule for mutually recursive definitions. 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. @@ -207,26 +212,56 @@ Similar to @racket[bind] for a variable, we use @racket[import] to declare that @subsection{Nested binding} -@(racketblock - (let* ([b:binding-pair ...]) e:guard-expr)) +There is another type of binding rule that doesn't fit into our state machine language, but you might need it when creating a language on your own. 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 next definition. Here is an example: @(racketblock - (nonterminal binding-pair - [v:local-var e:guard-expr])) + (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. 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, guard expressions are very limited. Let's remind ourselves what the grammar for a guard expression looks like: @(racketblock - (let* ([b:binding-pair ...]) e:guard-expr) - #:binding (nest b e)) + (nonterminal guard-expr + var-ref:event-var + n:number + (= e1:guard-expr e2:guard-expr))) + +A guard expression is either a variable reference, a number, or an equality test. What if we want something fancier like @racket[<]? Or what if we want to use values other than numbers? At this rate, we might as well allow arbitrary Racket expressions. Can we do that? Yes! @(racketblock - (nesting-nonterminal binding-pair (nested) - [v:local-var e:guard-expr] - #:binding (scope (bind v) nested))) + (syntax-spec + ... + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) action:action-spec) + #:binding (scope (bind arg)) + (on (event-name:id arg:event-var ...) #:when guard:racket-expr action:action-spec) + #:binding (scope (bind arg) guard)) + ...)) -@section[#:tag "racket"]{Integrating Racket Subexpressions} +Instead of using @racket[guard-expr] and defining our own nonterminal for guard 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 even control how references to our DSL-bound variables behave in Racket expressions using reference compilers, which we'll discuss in the @secref["compilation"] section. + +In addition to @racket[racket-expr], there is @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} +@;TODO arity check with symbol tables. actually no, because event name uses id. + @section[#:tag "macros"]{Macros} The full code for the state machine example is available at diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt new file mode 100644 index 0000000..fadf74c --- /dev/null +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -0,0 +1,104 @@ +#lang racket/base + +(require "../../testing.rkt" + racket/class + (for-syntax racket/list)) + +(syntax-spec + (binding-class event-var) + (binding-class state-name) + + (nonterminal/exporting state-spec + (state name:state-name transition:transition-spec ...) + #:binding (export name)) + + (nonterminal transition-spec + (on (event-name:id arg:event-var ...) action:action-spec) + #:binding (scope (bind arg)) + (on (event-name:id arg:event-var ...) #:when guard:racket-expr action:action-spec) + #:binding (scope (bind arg) guard)) + + (nonterminal action-spec + (goto next-state-name:state-name)) + + (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 + ; TODO handle when not all events are present in all states. should just ignore the event if no transition for it. + (syntax-parser + [(_ initial-state:id + ((~literal state) state-name evt ...) + ...) + (define/syntax-parse (all-events ...) (unique-event-names #'(evt ... ...))) + #'(with-reference-compilers ([event-var immutable-reference-compiler]) + ; no reference compiler for state names since they shouldn't be referenced in racket expressions. + (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-method all-events state) + ... + + (send this set-state initial-state) + (super-new))) + + (define common% + (class object% + (init-field machine) + (super-new))) + + (define state-name + (class common% + (inherit-field machine) + + (define/public (get-state) 'state-name) + + (compile-event-method evt machine) + ... + + (super-new))) + ... + + (new machine%)))])) + +(begin-for-syntax + (define (unique-event-names evt-stxs) + (remove-duplicates (map event-name (syntax->list evt-stxs)) + free-identifier=?)) + + (define (event-name e) + (syntax-parse e + [(on (name . _) . _) #'name]))) + +(define-syntax compile-proxy-method + (syntax-parser + [(_ name target) + #'(define/public (name . args) + (send/apply target name args))])) + +(define-syntax compile-event-method + (syntax-parser + #:datum-literals (on ->) + [(_ (on (event-name arg ...) (~optional (~seq #:where guard) #:defaults ([guard #'#t])) + (goto name)) + machine) + #'(define/public (event-name arg ...) + (when guard + (send machine set-state name)))])) + +(define mchn + (machine + #:initial green + (state green + (on (good) (goto green)) + (on (bad) (goto red))) + (state red + (on (bad) (goto red))))) + From f51da30264d192be444d72af8ec592507fd82e13 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 14 May 2024 13:54:28 -0400 Subject: [PATCH 05/27] simply typed lambda calculus dsl --- tests/dsls/simply-typed-lambda-calculus.rkt | 196 ++++++++++++++++++++ 1 file changed, 196 insertions(+) create mode 100644 tests/dsls/simply-typed-lambda-calculus.rkt diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt new file mode 100644 index 0000000..e340db9 --- /dev/null +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -0,0 +1,196 @@ +#lang racket/base + +(require "../../testing.rkt" + (for-syntax racket/match)) + +(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)) + ((~datum :) e:typed-expr t:type) + + ; rewrite for tagging applications + (~> (fun arg ...) + #'(#%app fun arg ...))) + (nonterminal type + Number + ((~literal ->) arg-type:type ... return-type:type)) + #;#; + (nonterminal/exporting typed-definition + #: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 ... e:typed-expr) + #:binding (re-export defn)) + (nonterminal/exporting typed-definition-or-expr + #:allow-extension typed-macro + #:binding-space stlc + defn:typed-definition + #:binding (re-export defn) + e:typed-expr) + (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)) + +(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 (symbol-table-ref types #'x (lambda () (raise-syntax-error 'infer-expr-type "untyped identifier" #'x)))] + [((~datum lambda) ([x:id _ t] ...) body) + (define arg-types (map parse-type (attribute t))) + (for ([x (attribute x)] + [t arg-types]) + (symbol-table-set! types 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)]) + (symbol-table-set! types x (infer-expr-type e))) + (infer-expr-type #'body)])) + + ; 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 -> 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)))]))) + +(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))])) + +(define-syntax define-stlc-syntax + (syntax-parser + [(_ name:id trans:expr) + #`(define-syntax #,((make-interned-syntax-introducer 'stlc) #'name 'add) + (typed-macro trans))])) + +(define-stlc-syntax let* + (syntax-parser + [(_ () body) #'(let () body)] + [(_ ([x:id e] binding ...) body) + #'(let ([x e]) (let* (binding ...) body))])) + +; testing + +(define-syntax-rule + (check-eval e v) + (check-equal? (stlc/expr 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))))) From 9022dbb4660d9d569ad048a63b6d888bd508477d Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 14 May 2024 18:47:21 -0400 Subject: [PATCH 06/27] racket exprs in stlc, syntax/loc in #%host-expression --- private/runtime/compile.rkt | 2 +- tests/dsls/simply-typed-lambda-calculus.rkt | 65 +++++++++++++++++++-- 2 files changed, 62 insertions(+), 5 deletions(-) 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/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index e340db9..65c4093 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -1,7 +1,8 @@ #lang racket/base (require "../../testing.rkt" - (for-syntax racket/match)) + racket/contract + (for-syntax racket/match syntax/transformer)) (syntax-spec (binding-class typed-var) @@ -25,6 +26,8 @@ #'(: e t)) ((~datum :) e:typed-expr t:type) + (rkt e:racket-expr (~datum :) t:type) + ; rewrite for tagging applications (~> (fun arg ...) #'(#%app fun arg ...))) @@ -48,7 +51,8 @@ (host-interface/expression (stlc/expr e:typed-expr) (infer-expr-type #'e) - #'(compile-expr e)) + #'(with-reference-compilers ([typed-var typed-var-reference-compiler]) + (compile-expr e))) (host-interface/expression (stlc/infer e:typed-expr) (define t (infer-expr-type #'e)) @@ -102,7 +106,9 @@ (for ([x (attribute x)] [e (attribute e)]) (symbol-table-set! types x (infer-expr-type e))) - (infer-expr-type #'body)])) + (infer-expr-type #'body)] + [((~datum rkt) e (~datum :) t) + (parse-type #'t)])) ; Syntax Type -> Void (define (check-expr-type e expected-type) @@ -142,7 +148,31 @@ #'((compile-expr f) (compile-expr arg) ...)] [(_ ((~datum :) e _)) #'(compile-expr e)] [(_ ((~datum let) ([x e] ...) body)) - #'(let ([x (compile-expr e)] ...) (compile-expr 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)])) + +(begin-for-syntax + (define typed-var-reference-compiler + ; TODO change to make-variable-like-reference-compiler + (make-variable-like-transformer (lambda (x) + #`(contract #,(type->contract-stx (symbol-table-ref types 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)]))) (define-syntax define-stlc-syntax (syntax-parser @@ -194,3 +224,30 @@ (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))))) From d019ad73fb8c19f0a392bb2ea622f31991e4cacf Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 14 May 2024 22:46:33 -0400 Subject: [PATCH 07/27] definitions in stlc --- tests/dsls/simply-typed-lambda-calculus.rkt | 87 ++++++++++++++++++--- 1 file changed, 77 insertions(+), 10 deletions(-) diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index 65c4093..eb9cd3b 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -34,18 +34,12 @@ (nonterminal type Number ((~literal ->) arg-type:type ... return-type:type)) - #;#; - (nonterminal/exporting typed-definition + (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 ... e:typed-expr) - #:binding (re-export defn)) - (nonterminal/exporting typed-definition-or-expr - #:allow-extension typed-macro - #:binding-space stlc - defn:typed-definition + (begin defn:typed-definition-or-expr ...+) #:binding (re-export defn) e:typed-expr) (host-interface/expression @@ -57,7 +51,13 @@ (stlc/infer e:typed-expr) (define t (infer-expr-type #'e)) (define t-datum (type->datum t)) - #`'#,t-datum)) + #`'#,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 (begin body ...)))) (begin-for-syntax ; a Type is one of @@ -120,6 +120,26 @@ (type->datum actual-type)) e))) + ; Syntax -> Void + (define (type-check-defn-or-expr/pass1 e) + (syntax-parse e + [((~datum #%define) x:id t _) + (symbol-table-set! types #'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 @@ -174,6 +194,15 @@ (define/syntax-parse return-type-stx (type->contract-stx return-type)) #'(-> arg-type-stx ... return-type-stx)]))) +(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) @@ -186,11 +215,20 @@ [(_ ([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 (define-syntax-rule (check-eval e v) - (check-equal? (stlc/expr e) v)) + (check-equal? (let () (stlc e)) v)) (define-syntax-rule (check-infer e t) (check-equal? (stlc/infer e) 't)) @@ -251,3 +289,32 @@ (stlc/expr (let ([f (lambda ([x : Number]) x)]) (rkt (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) From d657036d6b0dccb3edfe93e9565c561e0e79a106 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 15 May 2024 00:10:31 -0400 Subject: [PATCH 08/27] block and definition contexts in stlc expressions --- tests/dsls/simply-typed-lambda-calculus.rkt | 72 ++++++++++++++++++--- 1 file changed, 63 insertions(+), 9 deletions(-) diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index eb9cd3b..d561e20 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -1,5 +1,9 @@ #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. + (require "../../testing.rkt" racket/contract (for-syntax racket/match syntax/transformer)) @@ -14,11 +18,11 @@ x:typed-var n:number - (lambda ([x:typed-var (~datum :) t:type] ...) body:typed-expr) + (#%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) + (#%let ([x:typed-var e:typed-expr] ...) body:typed-expr) #:binding (scope (bind x) body) ; type annotation @@ -28,6 +32,9 @@ (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 ...))) @@ -73,7 +80,7 @@ (syntax-parse e [n:number (number-type)] [x:id (symbol-table-ref types #'x (lambda () (raise-syntax-error 'infer-expr-type "untyped identifier" #'x)))] - [((~datum lambda) ([x:id _ t] ...) body) + [((~datum #%lambda) ([x:id _ t] ...) body) (define arg-types (map parse-type (attribute t))) (for ([x (attribute x)] [t arg-types]) @@ -102,13 +109,17 @@ (define t (parse-type #'t-stx)) (check-expr-type #'e t) t] - [((~datum let) ([x e] ...) body) + [((~datum #%let) ([x e] ...) body) (for ([x (attribute x)] [e (attribute e)]) (symbol-table-set! types x (infer-expr-type e))) (infer-expr-type #'body)] [((~datum rkt) e (~datum :) t) - (parse-type #'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)])) ; Syntax Type -> Void (define (check-expr-type e expected-type) @@ -135,7 +146,7 @@ (syntax-parse e [((~datum #%define) _ t e) (check-expr-type #'e (parse-type #'t))] - [((~datum begin) body ...+) + [((~datum begin) body ...) (for ([body (attribute body)]) (type-check-defn-or-expr/pass2 body))] [e (void (infer-expr-type #'e))])) @@ -162,18 +173,23 @@ (syntax-parser [(_ n:number) #'n] [(_ x:id) #'x] - [(_ ((~datum lambda) ([x:id _ _] ...) body)) + [(_ ((~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)) + [(_ ((~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)])) + #f #'e)] + [(_ ((~datum block) d ... e)) + #'(let () + (compile-defn-or-expr d) + ... + (compile-expr e))])) (begin-for-syntax (define typed-var-reference-compiler @@ -209,6 +225,16 @@ #`(define-syntax #,((make-interned-syntax-introducer 'stlc) #'name 'add) (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)] @@ -318,3 +344,31 @@ 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) 1)) + 1) From 011b11f18596c1463b402c80c7ff7773bfe6f716 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 15 May 2024 00:10:41 -0400 Subject: [PATCH 09/27] update tutorial --- scribblings/tutorial.scrbl | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/scribblings/tutorial.scrbl b/scribblings/tutorial.scrbl index a4c9fcf..c85547d 100644 --- a/scribblings/tutorial.scrbl +++ b/scribblings/tutorial.scrbl @@ -1,6 +1,6 @@ #lang scribble/manual -@(require (for-label racket "../main.rkt")) +@(require (for-label racket racket/block "../main.rkt")) @title{Tutorial} @@ -179,16 +179,16 @@ These simple binding rules behave like @racket[let]: (binding-class my-var) (nonterminal my-expr (my-let ([x:my-var e:my-expr] ...) body:my-expr) - #:binding (group e (scope (bind x) body)) + #: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[action] or @racket[event-name] in the binding rules for transitions. -@subsection{Definition contexts} +@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 for state names is not like @racket[let]. It's more like @racket[define] where you can have mutual recursion. For that kind of binding structure, we use @racket[export] and @racket[import]: +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)) @@ -206,13 +206,13 @@ Now let's add binding rules for state names. We can't just use @racket[scope] an (nonterminal action-spec (goto next-state-name:state-name))) -We use an exporting nonterminal for @racket[state-spec], which allows us to use the @racket[export] binding rule for mutually recursive definitions. 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. +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] or 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 language on your own. 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 next definition. Here is an example: +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 @@ -242,7 +242,7 @@ In our state machine language, guard expressions are very limited. Let's remind n:number (= e1:guard-expr e2:guard-expr))) -A guard expression is either a variable reference, a number, or an equality test. What if we want something fancier like @racket[<]? Or what if we want to use values other than numbers? At this rate, we might as well allow arbitrary Racket expressions. Can we do that? Yes! +A guard expression is either a variable reference, a number, or an equality test. What if we want something fancier like @racket[<]? Or what if we want to use values other than numbers? Really, it'd be ideal to be able to allow arbitrary racket expressions for the guard. We can actually do that! @(racketblock (syntax-spec @@ -256,7 +256,7 @@ A guard expression is either a variable reference, a number, or an equality test Instead of using @racket[guard-expr] and defining our own nonterminal for guard 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 even control how references to our DSL-bound variables behave in Racket expressions using reference compilers, which we'll discuss in the @secref["compilation"] section. -In addition to @racket[racket-expr], there is @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. +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} From eb1aa7f2d93512c10405883686095c93af5e7980 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 15 May 2024 00:14:45 -0400 Subject: [PATCH 10/27] fix test case in stlc --- tests/dsls/simply-typed-lambda-calculus.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index d561e20..320e142 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -370,5 +370,5 @@ x) 1) (check-eval - ((lambda () (define x : Number 1) 1)) + ((lambda () (define x : Number 1) x)) 1) From d76115d130a4e7f9bd6f6fe386ab36bf05f57052 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 22 May 2024 00:01:41 -0400 Subject: [PATCH 11/27] state machine tutorial dsl prune unused states --- main.rkt | 5 ++ tests/dsls/state-machine-for-tutorial.rkt | 89 ++++++++++++++++++++--- 2 files changed, 83 insertions(+), 11 deletions(-) diff --git a/main.rkt b/main.rkt index b21e855..14852c8 100644 --- a/main.rkt +++ b/main.rkt @@ -17,6 +17,11 @@ symbol-table-set! symbol-table-ref + define-persistent-symbol-set + define-local-symbol-set + symbol-set-add! + symbol-set-member? + compiled-identifier=? free-identifiers alpha-equivalent?)) diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt index fadf74c..c1def1f 100644 --- a/tests/dsls/state-machine-for-tutorial.rkt +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "../../testing.rkt" + racket/match racket/class (for-syntax racket/list)) @@ -24,10 +25,50 @@ (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-parse (s^ ...) (prune-inaccessible-states #'initial-state (attribute s))) + #'(compile-machine initial-state s^ ...))) + +(begin-for-syntax + ; Identifier (listof Syntax) -> (listof Syntax) + ; removes inaccessible states' specs + (define (prune-inaccessible-states initial-state-id state-specs) + (define accessible-states (get-accessible-states initial-state-id state-specs)) + (for/list ([state-spec state-specs] + #:when (symbol-set-member? accessible-states (state-spec-name state-spec))) + state-spec)) + + ; Identifier (listof Syntax) -> SymbolSet + (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)) + (let loop ([state-name initial-state-id]) + (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)]) + (loop next-state-name)))) + 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 + (on action (~optional (~seq #:when guard)) + (goto next-state-name)) + ...) + (attribute next-state-name)]))) (define-syntax compile-machine - ; TODO handle when not all events are present in all states. should just ignore the event if no transition for it. + ; TODO handle when not all events are present in all states. should get a clearer error message. (syntax-parser [(_ initial-state:id ((~literal state) state-name evt ...) @@ -93,12 +134,38 @@ (when guard (send machine set-state name)))])) -(define mchn - (machine - #:initial green - (state green - (on (good) (goto green)) - (on (bad) (goto red))) - (state red - (on (bad) (goto red))))) - +(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) + (define machine-datum + (syntax->datum + (expand + #'(machine + #:initial the-initial-state + (state the-initial-state) + (state unreachable))))) + (define (symbol-in-datum? datum sym) + (match datum + [(cons a b) (or (symbol-in-datum? a sym) + (symbol-in-datum? b sym))] + [_ (eq? sym datum)])) + (check-true (symbol-in-datum? machine-datum 'the-initial-state)) + (check-false (symbol-in-datum? machine-datum 'unreachable))) From 1789836751bd1ec37490c71e09f10b1493ec7262 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Sat, 25 May 2024 19:06:38 -0400 Subject: [PATCH 12/27] tutorial state machine errors on inaccessible state --- tests/dsls/state-machine-for-tutorial.rkt | 97 +++++++++++++---------- 1 file changed, 53 insertions(+), 44 deletions(-) diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt index c1def1f..f28d193 100644 --- a/tests/dsls/state-machine-for-tutorial.rkt +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -1,5 +1,6 @@ #lang racket/base +(provide (all-defined-out)) (require "../../testing.rkt" racket/match racket/class @@ -25,17 +26,17 @@ (host-interface/expression (machine #:initial initial-state:state-name s:state-spec ...) #:binding (scope (import s) initial-state) - (define/syntax-parse (s^ ...) (prune-inaccessible-states #'initial-state (attribute s))) - #'(compile-machine initial-state s^ ...))) + (check-for-inaccessible-states #'initial-state (attribute s)) + #'(compile-machine initial-state s ...))) (begin-for-syntax ; Identifier (listof Syntax) -> (listof Syntax) - ; removes inaccessible states' specs - (define (prune-inaccessible-states initial-state-id state-specs) + ; 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] - #:when (symbol-set-member? accessible-states (state-spec-name state-spec))) - state-spec)) + #: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) @@ -77,37 +78,37 @@ #'(with-reference-compilers ([event-var immutable-reference-compiler]) ; no reference compiler for state names since they shouldn't be referenced in racket expressions. (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 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-method all-events state) - ... + (compile-proxy-method all-events state) + ... - (send this set-state initial-state) - (super-new))) + (send this set-state initial-state) + (super-new))) - (define common% - (class object% - (init-field machine) - (super-new))) + (define common% + (class object% + (init-field machine) + (super-new))) - (define state-name - (class common% - (inherit-field machine) + (define state-name + (class common% + (inherit-field machine) - (define/public (get-state) 'state-name) + (define/public (get-state) 'state-name) - (compile-event-method evt machine) - ... + (compile-event-method evt machine) + ... - (super-new))) - ... + (super-new))) + ... - (new machine%)))])) + (new machine%)))])) (begin-for-syntax (define (unique-event-names evt-stxs) @@ -127,7 +128,7 @@ (define-syntax compile-event-method (syntax-parser #:datum-literals (on ->) - [(_ (on (event-name arg ...) (~optional (~seq #:where guard) #:defaults ([guard #'#t])) + [(_ (on (event-name arg ...) (~optional (~seq #:when guard) #:defaults ([guard #'#t])) (goto name)) machine) #'(define/public (event-name arg ...) @@ -155,17 +156,25 @@ (check-equal? (send mchn get-state) 'red) - (define machine-datum - (syntax->datum - (expand - #'(machine - #:initial the-initial-state - (state the-initial-state) - (state unreachable))))) - (define (symbol-in-datum? datum sym) - (match datum - [(cons a b) (or (symbol-in-datum? a sym) - (symbol-in-datum? b sym))] - [_ (eq? sym datum)])) - (check-true (symbol-in-datum? machine-datum 'the-initial-state)) - (check-false (symbol-in-datum? machine-datum 'unreachable))) + (check-exn + #rx"machine: Inaccessible state: unreachable" + (lambda () + (convert-compile-time-error + (machine + #:initial the-initial-state + (state the-initial-state) + (state unreachable))))) + + #;(define turnstile + (machine + #:initial locked + + (state locked + (on (coin value) #:when (= value 0.25) + (goto unlocked)) + (on (coin value) + (goto locked))) + + (state unlocked + (on (person-enters) + (goto locked)))))) From 99a231c031479c232d2a08810a77185e6bbdc00d Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 28 May 2024 11:11:42 -0400 Subject: [PATCH 13/27] tutorial state machine works with turnstile dsl --- tests/dsls/state-machine-for-tutorial.rkt | 124 +++++++++++++++------- 1 file changed, 83 insertions(+), 41 deletions(-) diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt index f28d193..deeec9d 100644 --- a/tests/dsls/state-machine-for-tutorial.rkt +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -69,44 +69,28 @@ (attribute next-state-name)]))) (define-syntax compile-machine - ; TODO handle when not all events are present in all states. should get a clearer error message. (syntax-parser [(_ initial-state:id - ((~literal state) state-name evt ...) + (~and state-spec + ((~literal state) state-name evt ...)) ...) - (define/syntax-parse (all-events ...) (unique-event-names #'(evt ... ...))) - #'(with-reference-compilers ([event-var immutable-reference-compiler]) + ; TODO use a symbol table mapping state IDs to gensyms instead of using state name datums + (define/syntax-parse (event-name ...) (unique-event-names #'(evt ... ...))) + (define/syntax-parse (event-method ...) + (for/list ([event-name (attribute event-name)]) + (compile-event-method event-name (attribute state-spec)))) + #`(with-reference-compilers ([event-var immutable-reference-compiler]) ; no reference compiler for state names since they shouldn't be referenced in racket expressions. (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-method all-events state) - ... - - (send this set-state initial-state) - (super-new))) - - (define common% - (class object% - (init-field machine) - (super-new))) - - (define state-name - (class common% - (inherit-field machine) - - (define/public (get-state) 'state-name) - - (compile-event-method evt machine) - ... - - (super-new))) - ... + (super-new) + (define state 'initial-state) + (define/public (set-state! new-state) + (set! state new-state)) + (define/public (get-state) state) + event-method + ...)) (new machine%)))])) @@ -125,15 +109,58 @@ #'(define/public (name . args) (send/apply target name args))])) -(define-syntax compile-event-method +(begin-for-syntax + ; Identifier (listof Syntax) -> Syntax + (define (compile-event-method event-name state-specs) + (define/syntax-parse (state-name ...) + (for/list ([state-spec state-specs]) + (state-spec-name state-spec))) + (define/syntax-parse (state-spec ...) state-specs) + #`(define/public (#,event-name . args) + (match (send this get-state) + ['state-name + (apply (compile-event-handler-for-state #,event-name state-name (state-spec ...)) + args)] + ... + [state (error 'machine (format "Unknown state: ~a" state))])))) + +(define-syntax compile-event-handler-for-state (syntax-parser - #:datum-literals (on ->) - [(_ (on (event-name arg ...) (~optional (~seq #:when guard) #:defaults ([guard #'#t])) - (goto name)) - machine) - #'(define/public (event-name arg ...) - (when guard - (send machine set-state name)))])) + [(_ event-name state-name (state-spec ...)) + (define/syntax-parse + ((on (_ arg ...) (~optional (~seq #:when guard) #:defaults ([guard #'#t])) + (goto next-state-name)) + ...) + (get-transitions-for-event-and-state #'event-name #'state-name #'(state-spec ...))) + #'(lambda args + (cond + [(apply (lambda (arg ...) guard) + args) + (send this set-state! 'next-state-name)] + ... + [else (error 'machine + "No transition defined for event ~v in state ~v" + (syntax->datum #'event-name) + (syntax->datum #'state-name))]))])) + +(begin-for-syntax + ; Identifier Identifier (listof Syntax) -> (listof Syntax) + ; gets the transitions for the given event and state + (define (get-transitions-for-event-and-state event-name state-name state-specs) + (apply append + (for/list ([state-spec (syntax->list state-specs)] + #:when (compiled-identifier=? (state-spec-name state-spec) + state-name)) + (syntax-parse state-spec + [(state _ + transition + ...) + (for/list ([transition (attribute transition)] + #:when (syntax-parse transition + [(on (event-name^ . _) . _) + (eq? (syntax->datum event-name) + (syntax->datum #'event-name^))])) + transition)]))))) (module+ test (define mchn @@ -165,7 +192,7 @@ (state the-initial-state) (state unreachable))))) - #;(define turnstile + (define turnstile (machine #:initial locked @@ -177,4 +204,19 @@ (state unlocked (on (person-enters) - (goto locked)))))) + (goto locked))))) + (check-equal? (send turnstile get-state) + 'locked) + (send turnstile coin 0.10) + (check-equal? (send turnstile get-state) + 'locked) + (send turnstile coin 0.25) + (check-equal? (send turnstile get-state) + 'unlocked) + (send turnstile person-enters) + (check-equal? (send turnstile get-state) + 'locked) + (check-exn + #rx"machine: No transition defined for event 'person-enters in state 'locked" + (lambda () + (send turnstile person-enters)))) From cdb905d843c593573ea54f5893907ba55fbf8cf9 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 28 May 2024 13:23:07 -0400 Subject: [PATCH 14/27] rename tutorial to basic tutorial --- .../basic-tutorial.scrbl} | 288 +++++++++++++++++- 1 file changed, 278 insertions(+), 10 deletions(-) rename scribblings/{tutorial.scrbl => tutorial/basic-tutorial.scrbl} (51%) diff --git a/scribblings/tutorial.scrbl b/scribblings/tutorial/basic-tutorial.scrbl similarity index 51% rename from scribblings/tutorial.scrbl rename to scribblings/tutorial/basic-tutorial.scrbl index c85547d..123020f 100644 --- a/scribblings/tutorial.scrbl +++ b/scribblings/tutorial/basic-tutorial.scrbl @@ -1,8 +1,9 @@ #lang scribble/manual -@(require (for-label racket racket/block "../main.rkt")) +@(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../main.rkt") + scribble/example) -@title{Tutorial} +@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. @@ -20,7 +21,7 @@ We will: Here's what using the DSL to define a controller for a subway turnstile looks like: @(racketblock - (define turnstile% + (define turnstile (machine #:initial locked @@ -206,12 +207,14 @@ Now let's add binding rules for state names. We can't just use @racket[scope] an (nonterminal action-spec (goto next-state-name: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] or body or a @racket[block] form. +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} +@;TODO move this to the advanced tutorial and leave a note here + 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 @@ -228,7 +231,7 @@ There is another type of binding rule that doesn't fit into our state machine la 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. syntax-spec uses your language's binding rules to construct this scope tree during expansion. +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]. @@ -254,17 +257,282 @@ A guard expression is either a variable reference, a number, or an equality test #:binding (scope (bind arg) guard)) ...)) -Instead of using @racket[guard-expr] and defining our own nonterminal for guard 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 even control how references to our DSL-bound variables behave in Racket expressions using reference compilers, which we'll discuss in the @secref["compilation"] section. +Instead of using @racket[guard-expr] and defining our own nonterminal for guard 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} -@;TODO arity check with symbol tables. actually no, because event name uses id. +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. Let's start writing it: + +@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 + [(_ initial-state:id + (~and state-spec + ((~literal state) state-name evt ...)) + ...) + (define/syntax-parse (event-name ...) (unique-event-names #'(evt ... ...))) + (define/syntax-parse (event-method ...) + (for/list ([event-name (attribute event-name)]) + (compile-event-method event-name (attribute state-spec)))) + #'(with-reference-compilers ([event-var immutable-reference-compiler]) + ; no reference compiler for state names since they shouldn't be referenced in racket expressions. + (let () + (define machine% + (class object% + (super-new) + (define state 'initial-state) + (define/public (set-state! new-state) + (set! state new-state)) + (define/public (get-state) state) + event-method + ...)) + + (new machine%)))]))] + +We defined a macro, @racket[compile-machine], which emits a class definition for the machine and ultimately evaluates to an instance of the machine class. Most of this has nothing to do with syntax-spec and is what you'd see in a typical Racket macro compiler for a DSL. However, notice the use of @racket[with-reference-compilers]. This is from syntax-spec and it allows us to control how DSL-bound variables behave in Racket expression positions like the guard of a transition spec. In this case, we chose to use @racket[immutable-reference-compiler] to prevent mutation of @racket[event-var] variables. We intentionally don't provide a reference compiler for @racket[state-name] identifiers because they shouldn't be accessible from Racket expressions, only our DSL's @racket[goto] form. + +Now let's define the helpers referenced here: + +@racketblock[#:escape unracket +(begin-for-syntax + ; Syntax -> Identifier + (define (state-spec-name state-spec) + (syntax-parse state-spec + [(state name . _) #'name])) + + (define (unique-event-names evt-stxs) + (remove-duplicates (map event-name (syntax->list evt-stxs)) + (lambda (a b) (eq? (syntax->datum a) (syntax->datum b))))) + + (define (event-name e) + (syntax-parse e + [(on (name . _) . _) #'name]))) + +(begin-for-syntax + ; Identifier (listof Syntax) -> Syntax + (define (compile-event-method event-name state-specs) + (define/syntax-parse (state-name ...) + (for/list ([state-spec state-specs]) + (state-spec-name state-spec))) + (define/syntax-parse (state-spec ...) state-specs) + #`(define/public (#,event-name . args) + (match (send this get-state) + ['state-name + (apply (compile-event-handler-for-state #,event-name state-name (state-spec ...)) + args)] + ... + [state (error 'machine (format "Unknown state: ~a" state))])))) + +(define-syntax compile-event-handler-for-state + (syntax-parser + [(_ event-name state-name (state-spec ...)) + (define/syntax-parse + ((on (_ arg ...) (~optional (~seq #:when guard) #:defaults ([guard #'#t])) + (goto next-state-name)) + ...) + (get-transitions-for-event-and-state #'event-name #'state-name #'(state-spec ...))) + #'(lambda args + (cond + [(apply (lambda (arg ...) guard) + args) + (send this set-state! 'next-state-name)] + ... + [else (error 'machine + "No transition defined for event ~v in state ~v" + (syntax->datum #'event-name) + (syntax->datum #'state-name))]))])) + +(begin-for-syntax + ; Identifier Identifier (listof Syntax) -> (listof Syntax) + ; gets the transitions for the given event and state + (define (get-transitions-for-event-and-state evt-name state-name state-specs) + (apply append + (for/list ([state-spec (syntax->list state-specs)] + #:when (compiled-identifier=? (state-spec-name state-spec) + state-name)) + (syntax-parse state-spec + [(state _ + transition + ...) + (for/list ([transition (attribute transition)] + #:when (eq? (syntax->datum evt-name) + (syntax->datum (event-name transition)))) + transition)])))))] + +Most of these helpers don't involve anything syntax-spec specific, so we won't talk about them much. For each event, we One thing to note is that Racket expressions like @racket[guard] in @racket[compile-event-handler-for-state] 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. + +Our last helper, @racket[get-transitions-for-event-and-state], uses @racket[compiled-identifier=?] from syntax-spec to compare state names. syntax-spec compiles and renames DSL identifiers to ensure proper hygiene and allow for some utilities like symbol tables, which we'll discuss soon. We compare DSL identifiers using @racket[compiled-identifier=?]. + +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 turnstile + (machine + #:initial locked + + (state locked + (on (coin value) #:when (= value 0.25) + (goto unlocked)) + (on (coin value) + (goto locked))) + + (state unlocked + (on (person-enters) + (goto locked))))) +(send turnstile get-state) +(send turnstile coin 0.05) +(send turnstile get-state) +(send turnstile coin 0.25) +(send turnstile get-state) +(send turnstile person-enters) +(send turnstile 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)) + (let loop ([state-name initial-state-id]) + (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)]) + (loop next-state-name)))) + 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 + (on action (~optional (~seq #:when guard)) + (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} -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}. +syntax-spec allows us to make our DSLs macro-extensible. For example, let's allow users to create macros for definining states: -@;TODO demonstrate symbol tables by doing an arity check on actions? +@racketblock[ +(syntax-spec + ... + (extension-class state-macro) + + (nonterminal/exporting state-spec + #:allow-extension state-macro + (state name:state-name transition:transition-spec ...) + #:binding (export name))) + +(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}. From 129986222efbcb7beee3a406611009177b8d837d Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 28 May 2024 22:15:17 -0400 Subject: [PATCH 15/27] simply typed lambda calculus inserts contract around host interface --- tests/dsls/simply-typed-lambda-calculus.rkt | 311 +++++++++++--------- 1 file changed, 176 insertions(+), 135 deletions(-) diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index 320e142..811eedf 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -4,6 +4,8 @@ ; 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 "../../testing.rkt" racket/contract (for-syntax racket/match syntax/transformer)) @@ -40,7 +42,7 @@ #'(#%app fun arg ...))) (nonterminal type Number - ((~literal ->) arg-type:type ... return-type:type)) + ((~datum ->) arg-type:type ... return-type:type)) (nonterminal/exporting typed-definition-or-expr #:allow-extension typed-macro #:binding-space stlc @@ -51,9 +53,8 @@ e:typed-expr) (host-interface/expression (stlc/expr e:typed-expr) - (infer-expr-type #'e) - #'(with-reference-compilers ([typed-var typed-var-reference-compiler]) - (compile-expr e))) + (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)) @@ -64,7 +65,7 @@ #: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 ...)))) + #'(compile-defn-or-expr/top (begin body ...)))) (begin-for-syntax ; a Type is one of @@ -79,12 +80,12 @@ (define (infer-expr-type e) (syntax-parse e [n:number (number-type)] - [x:id (symbol-table-ref types #'x (lambda () (raise-syntax-error 'infer-expr-type "untyped identifier" #'x)))] + [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]) - (symbol-table-set! types x t)) + (extend-type-environment! x t)) (define body-type (infer-expr-type #'body)) (function-type arg-types body-type)] [((~datum #%app) f arg ...) @@ -112,7 +113,7 @@ [((~datum #%let) ([x e] ...) body) (for ([x (attribute x)] [e (attribute e)]) - (symbol-table-set! types x (infer-expr-type e))) + (extend-type-environment! x (infer-expr-type e))) (infer-expr-type #'body)] [((~datum rkt) e (~datum :) t) (parse-type #'t)] @@ -121,6 +122,15 @@ (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) + (void (symbol-table-ref types x (lambda () (symbol-table-set! types x t))))) + ; Syntax Type -> Void (define (check-expr-type e expected-type) (define actual-type (infer-expr-type e)) @@ -135,7 +145,7 @@ (define (type-check-defn-or-expr/pass1 e) (syntax-parse e [((~datum #%define) x:id t _) - (symbol-table-set! types #'x (parse-type #'t))] + (extend-type-environment! #'x (parse-type #'t))] [((~datum begin) body ...) (for ([body (attribute body)]) (type-check-defn-or-expr/pass1 body))] @@ -169,6 +179,19 @@ (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) + (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^)])) + (define-syntax compile-expr (syntax-parser [(_ n:number) #'n] @@ -193,12 +216,12 @@ (begin-for-syntax (define typed-var-reference-compiler - ; TODO change to make-variable-like-reference-compiler - (make-variable-like-transformer (lambda (x) - #`(contract #,(type->contract-stx (symbol-table-ref types x)) - #,x - 'stlc 'racket - '#,x #'#,x)))) + (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 @@ -210,10 +233,20 @@ (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)))] + [(_ ((~datum begin) body ...+)) + #'(begin (compile-defn-or-expr/top body) ...)] + [(_ e) + #`(compile-expr/top e #,(infer-expr-type #'e))])) + (define-syntax compile-defn-or-expr (syntax-parser [(_ ((~datum #%define) x:id _ body)) - #'(define x (compile-expr body))] + #`(define x (compile-expr body))] [(_ ((~datum begin) body ...+)) #'(begin (compile-defn-or-expr body) ...)] [(_ e) @@ -252,123 +285,131 @@ ; testing -(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))))) -; definitions -(check-equal? - (let () - (stlc +(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) -; 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) + 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)) From 7e5a8dd91e4bd422bf47bb58cde6163e2aa27ce6 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 29 May 2024 00:36:57 -0400 Subject: [PATCH 16/27] start stlc tutorial --- scribblings/main.scrbl | 4 +- scribblings/tutorial/basic-tutorial.scrbl | 2 +- scribblings/tutorial/main.scrbl | 12 + scribblings/tutorial/stlc-tutorial.scrbl | 261 ++++++++++++++++++++ tests/dsls/simply-typed-lambda-calculus.rkt | 6 +- 5 files changed, 280 insertions(+), 5 deletions(-) create mode 100644 scribblings/tutorial/main.scrbl create mode 100644 scribblings/tutorial/stlc-tutorial.scrbl 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/tutorial/basic-tutorial.scrbl b/scribblings/tutorial/basic-tutorial.scrbl index 123020f..f2c2aff 100644 --- a/scribblings/tutorial/basic-tutorial.scrbl +++ b/scribblings/tutorial/basic-tutorial.scrbl @@ -1,6 +1,6 @@ #lang scribble/manual -@(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../main.rkt") +@(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../../main.rkt") scribble/example) @title{Basic Tutorial: State Machine Language} diff --git a/scribblings/tutorial/main.scrbl b/scribblings/tutorial/main.scrbl new file mode 100644 index 0000000..6d1ad90 --- /dev/null +++ b/scribblings/tutorial/main.scrbl @@ -0,0 +1,12 @@ +#lang scribble/manual + +@(require (for-label racket)) + +@title{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..8ff0847 --- /dev/null +++ b/scribblings/tutorial/stlc-tutorial.scrbl @@ -0,0 +1,261 @@ +#lang scribble/manual + +@(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../../main.rkt") + scribble/example) + +@title{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. + +We will: + +@itemlist[ +@;TODO +] + +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. + +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: + +@racket[ +(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! + +@racket[ +((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 arbitrary racket expressions and allow DSL variables to be referenced in those 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. + +@;TODO left off here about to do rkt, contract checks, compile/top, etc. + +@;TODO definitions, implicit block in let +@;TODO let* ? diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index 811eedf..edaf08f 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -30,7 +30,7 @@ ; type annotation (~> (e (~datum :) t) #'(: e t)) - ((~datum :) e:typed-expr t:type) + (: e:typed-expr t:type) (rkt e:racket-expr (~datum :) t:type) @@ -252,11 +252,11 @@ [(_ e) #'(compile-expr e)])) + (define-syntax define-stlc-syntax (syntax-parser [(_ name:id trans:expr) - #`(define-syntax #,((make-interned-syntax-introducer 'stlc) #'name 'add) - (typed-macro trans))])) + #'(define-extension name typed-macro trans)])) (define-stlc-syntax let (syntax-parser From cbf54c42a38067a4cc812fc7cd77457ad0edb8cb Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 29 May 2024 00:38:02 -0400 Subject: [PATCH 17/27] finish state machine tutorial code --- tests/dsls/state-machine-for-tutorial.rkt | 51 ++++++++++++++++------- 1 file changed, 36 insertions(+), 15 deletions(-) diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt index deeec9d..a6f3d28 100644 --- a/tests/dsls/state-machine-for-tutorial.rkt +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -9,8 +9,10 @@ (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 transition:transition-spec ...) #:binding (export name)) @@ -74,12 +76,11 @@ (~and state-spec ((~literal state) state-name evt ...)) ...) - ; TODO use a symbol table mapping state IDs to gensyms instead of using state name datums (define/syntax-parse (event-name ...) (unique-event-names #'(evt ... ...))) (define/syntax-parse (event-method ...) (for/list ([event-name (attribute event-name)]) (compile-event-method event-name (attribute state-spec)))) - #`(with-reference-compilers ([event-var immutable-reference-compiler]) + #'(with-reference-compilers ([event-var immutable-reference-compiler]) ; no reference compiler for state names since they shouldn't be referenced in racket expressions. (let () (define machine% @@ -97,18 +98,12 @@ (begin-for-syntax (define (unique-event-names evt-stxs) (remove-duplicates (map event-name (syntax->list evt-stxs)) - free-identifier=?)) + (lambda (a b) (eq? (syntax->datum a) (syntax->datum b))))) (define (event-name e) (syntax-parse e [(on (name . _) . _) #'name]))) -(define-syntax compile-proxy-method - (syntax-parser - [(_ name target) - #'(define/public (name . args) - (send/apply target name args))])) - (begin-for-syntax ; Identifier (listof Syntax) -> Syntax (define (compile-event-method event-name state-specs) @@ -146,7 +141,7 @@ (begin-for-syntax ; Identifier Identifier (listof Syntax) -> (listof Syntax) ; gets the transitions for the given event and state - (define (get-transitions-for-event-and-state event-name state-name state-specs) + (define (get-transitions-for-event-and-state evt-name state-name state-specs) (apply append (for/list ([state-spec (syntax->list state-specs)] #:when (compiled-identifier=? (state-spec-name state-spec) @@ -156,12 +151,14 @@ transition ...) (for/list ([transition (attribute transition)] - #:when (syntax-parse transition - [(on (event-name^ . _) . _) - (eq? (syntax->datum event-name) - (syntax->datum #'event-name^))])) + #:when (eq? (syntax->datum evt-name) + (syntax->datum (event-name transition)))) transition)]))))) +(define-syntax-rule + (define-state-syntax name trans) + (define-extension name state-macro trans)) + (module+ test (define mchn (machine @@ -219,4 +216,28 @@ (check-exn #rx"machine: No transition defined for event 'person-enters in state 'locked" (lambda () - (send turnstile person-enters)))) + (send turnstile person-enters))) + + (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)) From b183ec0c35a1e9989d1c16f5775f7b04380416f7 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 29 May 2024 00:38:40 -0400 Subject: [PATCH 18/27] =?UTF-8?q?document=20compiled-identifier=3D=3F?= --- scribblings/reference/compiling.scrbl | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/scribblings/reference/compiling.scrbl b/scribblings/reference/compiling.scrbl index 55f7cae..80bc49e 100644 --- a/scribblings/reference/compiling.scrbl +++ b/scribblings/reference/compiling.scrbl @@ -91,7 +91,15 @@ Like @racket[free-id-table-ref] @section{Binding Operations} -@defproc[(free-identifiers [stx (syntax?)] [#:allow-host? allow-host? boolean? #f]) (listof identifier?)] +@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). From d8bd475dd36cc4d75816df3424322d939ed3cefb Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 30 May 2024 00:26:47 -0400 Subject: [PATCH 19/27] rkt in stlc tutorial --- scribblings/tutorial/stlc-tutorial.scrbl | 101 +++++++++++++++++++- tests/dsls/simply-typed-lambda-calculus.rkt | 11 ++- 2 files changed, 105 insertions(+), 7 deletions(-) diff --git a/scribblings/tutorial/stlc-tutorial.scrbl b/scribblings/tutorial/stlc-tutorial.scrbl index 8ff0847..2a0f6fd 100644 --- a/scribblings/tutorial/stlc-tutorial.scrbl +++ b/scribblings/tutorial/stlc-tutorial.scrbl @@ -241,21 +241,114 @@ Let's add arbitrary Racket expressions to our language. These can evaluate to an 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: -@racket[ +@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! -@racket[ +@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 arbitrary racket expressions and allow DSL variables to be referenced in those 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. +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)) + + ...) + +(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)))) +] -@;TODO left off here about to do rkt, contract checks, compile/top, etc. +@;TODO fix weird blame location @;TODO definitions, implicit block in let @;TODO let* ? diff --git a/tests/dsls/simply-typed-lambda-calculus.rkt b/tests/dsls/simply-typed-lambda-calculus.rkt index edaf08f..c4fbf5b 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -5,7 +5,8 @@ ; static analysis, rewrites, and custom reference compilers. (provide (all-defined-out) - (for-syntax (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)) @@ -190,7 +191,7 @@ #`(contract #,(type->contract-stx t) e^ 'stlc 'racket - #f #'e^)])) + #f #'e)])) (define-syntax compile-expr (syntax-parser @@ -412,4 +413,8 @@ 1) (check-eval ((lambda () (define x : Number 1) x)) - 1)) + 1) + (check-eval + (let ([add (rkt + : (-> Number Number Number))]) + (add 1 2)) + 3)) From dffd43dfe53dcac7d99201e38e547de5ed8d2944 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Tue, 4 Jun 2024 20:00:35 -0400 Subject: [PATCH 20/27] edits from call --- scribblings/tutorial/basic-tutorial.scrbl | 6 ++++-- scribblings/tutorial/main.scrbl | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/scribblings/tutorial/basic-tutorial.scrbl b/scribblings/tutorial/basic-tutorial.scrbl index f2c2aff..840653a 100644 --- a/scribblings/tutorial/basic-tutorial.scrbl +++ b/scribblings/tutorial/basic-tutorial.scrbl @@ -283,7 +283,7 @@ However, our compiler, which performs the actual translation, is not defined. Le (host-interface/expression (machine #:initial initial-state:state-name s:state-spec ...) #:binding (scope (import s) initial-state) - #'(compile-machine initial-state s^ ...)) + #'(compile-machine initial-state s ...)) ...) (define-syntax compile-machine @@ -381,7 +381,9 @@ Now let's define the helpers referenced here: (syntax->datum (event-name transition)))) transition)])))))] -Most of these helpers don't involve anything syntax-spec specific, so we won't talk about them much. For each event, we One thing to note is that Racket expressions like @racket[guard] in @racket[compile-event-handler-for-state] 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. +Most of these helpers don't involve anything syntax-spec specific, so we won't talk about them much. For each event, we +@;TODO finish this sentence +One thing to note is that Racket expressions like @racket[guard] in @racket[compile-event-handler-for-state] 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. Our last helper, @racket[get-transitions-for-event-and-state], uses @racket[compiled-identifier=?] from syntax-spec to compare state names. syntax-spec compiles and renames DSL identifiers to ensure proper hygiene and allow for some utilities like symbol tables, which we'll discuss soon. We compare DSL identifiers using @racket[compiled-identifier=?]. diff --git a/scribblings/tutorial/main.scrbl b/scribblings/tutorial/main.scrbl index 6d1ad90..4e96f0f 100644 --- a/scribblings/tutorial/main.scrbl +++ b/scribblings/tutorial/main.scrbl @@ -2,7 +2,7 @@ @(require (for-label racket)) -@title{Tutorial} +@title[#:style '(toc unnumbered)]{Tutorial} The tutorial is broken down into illustrative examples: From 87a83e687e940b8014fe6506c84301244b30bfc4 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Wed, 12 Jun 2024 00:55:11 -0400 Subject: [PATCH 21/27] state machine tutorial has actions instead of guards --- scribblings/tutorial/basic-tutorial.scrbl | 417 ++++++++++++---------- tests/dsls/state-machine-for-tutorial.rkt | 196 +++++----- 2 files changed, 316 insertions(+), 297 deletions(-) diff --git a/scribblings/tutorial/basic-tutorial.scrbl b/scribblings/tutorial/basic-tutorial.scrbl index 840653a..283574e 100644 --- a/scribblings/tutorial/basic-tutorial.scrbl +++ b/scribblings/tutorial/basic-tutorial.scrbl @@ -21,37 +21,31 @@ We will: 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) - (goto unlocked)) - (on (coin value) - (goto locked))) - - (state unlocked - (on (person-enters) - (goto 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. +(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[coin]. +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 is used to implement the guard on the transition to the unlocked state, which checks -that the given coin is a quarter. - - +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} @@ -75,19 +69,17 @@ Our initial specification with @racket[syntax-spec] supplies the grammar: (error 'machine "compiler not yet implemented")) (nonterminal state-spec - (state name:id transitions:transition-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) - (on (event-name:id arg:id ...) #:when guard:guard-expr action:action-spec)) + (on (event-name:id arg:id ...) + action:action-spec + ... + ((~datum goto) next-state:id))) (nonterminal action-spec - (goto next-state-name:id)) - - (nonterminal guard-expr - var-ref:id - n:number - (= e1:guard-expr e2:guard-expr))) + ((~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. @@ -122,20 +114,16 @@ Consider this program: (machine #:initial red (state red - (on (event x) #:when (= y 10) + (on (event x) (goto green)) (on (event x) (goto red)))) ] -In the guard @racket[(= y 10)], the @racket[y] is unbound. -Additionally, our first transition is to @racket[green], but there is no @racket[green] state. -Our compiled code will end up containing an unbound variable reference for @racket[y], so Racket's -expander will raise an error. +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], -and we changed the guard to @racket[(= x 10)] instead of @racket[(= y 10)], so there's no unbound reference to @racket[y]. +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. @@ -143,7 +131,7 @@ We could adjust our compiler to check for unbound state references, but syntax-s 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, it allows 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! +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} @@ -159,19 +147,20 @@ First, let's declare that the arguments to an action are in scope in the guard e @(racketblock (syntax-spec (binding-class event-var) + ... + (nonterminal transition-spec - (on (event-name:id arg:event-var ...) action:action-spec) - #:binding (scope (bind arg)) - (on (event-name:id arg:event-var ...) #:when guard:guard-expr action:action-spec) - #:binding (scope (bind arg) guard)) - ... - (nonterminal guard-expr - var-ref:event-var - n:number - (= e1:guard-expr e2:guard-expr)))) + (on (event-name:id arg:event-var ...) + action:action-spec + ... + ((~datum goto) next-state:id))) + #:binding (scope (bind arg) body) -We added a binding class, @racket[event-var], for an event's argument names. We also added a @racket[#:binding] declaration to guarded transitions to declare that the @racket[arg]s are bound in the @racket[guard] expression and this binding introduces a new scope. Although there are no reference positions in a non-guarded transition, we still need to declare the binding rule. Otherwise, by default, syntax-spec will assume that the @racket[arg] is a reference position, which will cause @racket[arg] to be unbound. When we don't include any binding rule for a production at all, a default binding rule is implicitly generated which treats all forms as reference positions. + (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]: @@ -185,7 +174,7 @@ These simple binding rules behave like @racket[let]: 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[action] or @racket[event-name] in the binding rules for transitions. +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} @@ -201,11 +190,17 @@ Now let's add binding rules for state names. We can't just use @racket[scope] an (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 action-spec - (goto next-state-name:state-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. @@ -213,8 +208,6 @@ Similar to @racket[bind] for a variable, we use @racket[import] to declare that @subsection{Nested binding} -@;TODO move this to the advanced tutorial and leave a note here - 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 @@ -237,27 +230,35 @@ From the simple nonterminal @racket[my-expr], we put the @racket[binding-pair]'s @section[#:tag "racket"]{Integrating Racket Subexpressions} -In our state machine language, guard expressions are very limited. Let's remind ourselves what the grammar for a guard expression looks like: +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 guard-expr - var-ref:event-var - n:number - (= e1:guard-expr e2:guard-expr))) + (nonterminal action-spec + ((~datum displayln) x:event-var))) -A guard expression is either a variable reference, a number, or an equality test. What if we want something fancier like @racket[<]? Or what if we want to use values other than numbers? Really, it'd be ideal to be able to allow arbitrary racket expressions for the guard. We can actually do that! +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 ...) action:action-spec) - #:binding (scope (bind arg)) - (on (event-name:id arg:event-var ...) #:when guard:racket-expr action:action-spec) - #:binding (scope (bind arg) guard)) + (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[guard-expr] and defining our own nonterminal for guard 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. +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. @@ -275,7 +276,84 @@ Now that we have our grammar and binding rules defined, we must write a compiler ...) ] -However, our compiler, which performs the actual translation, is not defined. Let's start writing it: +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 @@ -288,104 +366,71 @@ However, our compiler, which performs the actual translation, is not defined. Le (define-syntax compile-machine (syntax-parser - [(_ initial-state:id - (~and state-spec - ((~literal state) state-name evt ...)) + #:datum-literals (machine state on-enter) + [(_ initial-state + (state state-name + (~optional (on-enter action ...) #:defaults ([(action 1) '()])) + e ...) ...) - (define/syntax-parse (event-name ...) (unique-event-names #'(evt ... ...))) - (define/syntax-parse (event-method ...) - (for/list ([event-name (attribute event-name)]) - (compile-event-method event-name (attribute state-spec)))) - #'(with-reference-compilers ([event-var immutable-reference-compiler]) - ; no reference compiler for state names since they shouldn't be referenced in racket expressions. + #'(with-reference-compilers ([event-var mutable-reference-compiler]) (let () (define machine% (class object% - (super-new) - (define state 'initial-state) - (define/public (set-state! new-state) - (set! state new-state)) - (define/public (get-state) state) - event-method - ...)) + (define state #f) + (define/public (set-state state%) + (set! state (new state% [machine this]))) + (define/public (get-state) + (send state get-state)) - (new machine%)))]))] + (compile-proxy-methods (e ... ...) state) -We defined a macro, @racket[compile-machine], which emits a class definition for the machine and ultimately evaluates to an instance of the machine class. Most of this has nothing to do with syntax-spec and is what you'd see in a typical Racket macro compiler for a DSL. However, notice the use of @racket[with-reference-compilers]. This is from syntax-spec and it allows us to control how DSL-bound variables behave in Racket expression positions like the guard of a transition spec. In this case, we chose to use @racket[immutable-reference-compiler] to prevent mutation of @racket[event-var] variables. We intentionally don't provide a reference compiler for @racket[state-name] identifiers because they shouldn't be accessible from Racket expressions, only our DSL's @racket[goto] form. + (send this set-state initial-state) + (super-new))) -Now let's define the helpers referenced here: + (define state-name + (class object% + (init-field machine) + (define/public (get-state) + 'state-name) + action ... + (compile-event-method e machine) ... + (super-new))) + ... -@racketblock[#:escape unracket -(begin-for-syntax - ; Syntax -> Identifier - (define (state-spec-name state-spec) - (syntax-parse state-spec - [(state name . _) #'name])) + (new machine%)))])) +] - (define (unique-event-names evt-stxs) - (remove-duplicates (map event-name (syntax->list evt-stxs)) - (lambda (a b) (eq? (syntax->datum a) (syntax->datum b))))) +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]. - (define (event-name e) - (syntax-parse e - [(on (name . _) . _) #'name]))) +We have helpers to define the proxy methods in the @racket[machine%] class and transition methods in the state classes: -(begin-for-syntax - ; Identifier (listof Syntax) -> Syntax - (define (compile-event-method event-name state-specs) - (define/syntax-parse (state-name ...) - (for/list ([state-spec state-specs]) - (state-spec-name state-spec))) - (define/syntax-parse (state-spec ...) state-specs) - #`(define/public (#,event-name . args) - (match (send this get-state) - ['state-name - (apply (compile-event-handler-for-state #,event-name state-name (state-spec ...)) - args)] - ... - [state (error 'machine (format "Unknown state: ~a" state))])))) - -(define-syntax compile-event-handler-for-state +@(racketblock +(define-syntax compile-proxy-methods (syntax-parser - [(_ event-name state-name (state-spec ...)) - (define/syntax-parse - ((on (_ arg ...) (~optional (~seq #:when guard) #:defaults ([guard #'#t])) - (goto next-state-name)) - ...) - (get-transitions-for-event-and-state #'event-name #'state-name #'(state-spec ...))) - #'(lambda args - (cond - [(apply (lambda (arg ...) guard) - args) - (send this set-state! 'next-state-name)] - ... - [else (error 'machine - "No transition defined for event ~v in state ~v" - (syntax->datum #'event-name) - (syntax->datum #'state-name))]))])) + #: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))])) +) -(begin-for-syntax - ; Identifier Identifier (listof Syntax) -> (listof Syntax) - ; gets the transitions for the given event and state - (define (get-transitions-for-event-and-state evt-name state-name state-specs) - (apply append - (for/list ([state-spec (syntax->list state-specs)] - #:when (compiled-identifier=? (state-spec-name state-spec) - state-name)) - (syntax-parse state-spec - [(state _ - transition - ...) - (for/list ([transition (attribute transition)] - #:when (eq? (syntax->datum evt-name) - (syntax->datum (event-name transition)))) - transition)])))))] - -Most of these helpers don't involve anything syntax-spec specific, so we won't talk about them much. For each event, we -@;TODO finish this sentence -One thing to note is that Racket expressions like @racket[guard] in @racket[compile-event-handler-for-state] 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. - -Our last helper, @racket[get-transitions-for-event-and-state], uses @racket[compiled-identifier=?] from syntax-spec to compare state names. syntax-spec compiles and renames DSL identifiers to ensure proper hygiene and allow for some utilities like symbol tables, which we'll discuss soon. We compare DSL identifiers using @racket[compiled-identifier=?]. +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: @@ -393,26 +438,28 @@ Now we have all the pieces to run programs using state machines: #:label #f (require racket/class syntax-spec/tests/dsls/state-machine-for-tutorial) -(define turnstile +(define vending-machine (machine - #:initial locked - - (state locked - (on (coin value) #:when (= value 0.25) - (goto unlocked)) - (on (coin value) - (goto locked))) - - (state unlocked - (on (person-enters) - (goto locked))))) -(send turnstile get-state) -(send turnstile coin 0.05) -(send turnstile get-state) -(send turnstile coin 0.25) -(send turnstile get-state) -(send turnstile person-enters) -(send turnstile get-state) + #: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} @@ -430,7 +477,7 @@ In our language's compiler, we can use symbol set to raise an error when a state (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^ ...)) + #'(compile-machine initial-state s ...)) ...) (begin-for-syntax @@ -446,12 +493,13 @@ In our language's compiler, we can use symbol set to raise an error when a state (findf (lambda (state-spec) (compiled-identifier=? state-name (state-spec-name state-spec))) state-specs)) - (let loop ([state-name initial-state-id]) + (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)]) - (loop next-state-name)))) + (add-reachable-states! next-state-name)))) + (add-reachable-states! initial-state-id) accessible-states) (define (state-spec-name state-spec) @@ -461,8 +509,11 @@ In our language's compiler, we can use symbol set to raise an error when a state (define (state-spec-next-state-names state-spec) (syntax-parse state-spec [(state name - (on action (~optional (~seq #:when guard)) - (goto next-state-name)) + (~or ((~datum on-enter) . _) + ((~datum on) ev + body + ... + (goto next-state-name))) ...) (attribute next-state-name)]))) ] @@ -500,8 +551,8 @@ syntax-spec allows us to make our DSLs macro-extensible. For example, let's allo (nonterminal/exporting state-spec #:allow-extension state-macro - (state name:state-name transition:transition-spec ...) - #:binding (export name))) + + ...)) (define-syntax-rule (define-state-syntax name trans) @@ -538,3 +589,5 @@ Now let's create a macro in our language! 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/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt index a6f3d28..226d0a7 100644 --- a/tests/dsls/state-machine-for-tutorial.rkt +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -2,7 +2,6 @@ (provide (all-defined-out)) (require "../../testing.rkt" - racket/match racket/class (for-syntax racket/list)) @@ -13,21 +12,24 @@ (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 ...) action:action-spec) - #:binding (scope (bind arg)) - (on (event-name:id arg:event-var ...) #:when guard:racket-expr action:action-spec) - #:binding (scope (bind arg) guard)) - - (nonterminal action-spec - (goto next-state-name:state-name)) + (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 ...))) @@ -47,12 +49,13 @@ (findf (lambda (state-spec) (compiled-identifier=? state-name (state-spec-name state-spec))) state-specs)) - (let loop ([state-name initial-state-id]) + (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)]) - (loop next-state-name)))) + (add-reachable-states! next-state-name)))) + (add-reachable-states! initial-state-id) accessible-states) ; Syntax -> Identifier @@ -65,95 +68,70 @@ (define (state-spec-next-state-names state-spec) (syntax-parse state-spec [(state name - (on action (~optional (~seq #:when guard)) - (goto next-state-name)) + (~or ((~datum on-enter) . _) + ((~datum on) ev + body + ... + (goto next-state-name))) ...) (attribute next-state-name)]))) (define-syntax compile-machine (syntax-parser - [(_ initial-state:id - (~and state-spec - ((~literal state) state-name evt ...)) + #:datum-literals (machine state on-enter) + [(_ initial-state + (state state-name + (~optional (on-enter action ...) #:defaults ([(action 1) '()])) + e ...) ...) - (define/syntax-parse (event-name ...) (unique-event-names #'(evt ... ...))) - (define/syntax-parse (event-method ...) - (for/list ([event-name (attribute event-name)]) - (compile-event-method event-name (attribute state-spec)))) - #'(with-reference-compilers ([event-var immutable-reference-compiler]) - ; no reference compiler for state names since they shouldn't be referenced in racket expressions. + #'(with-reference-compilers ([event-var mutable-reference-compiler]) (let () (define machine% (class object% - (super-new) - (define state 'initial-state) - (define/public (set-state! new-state) - (set! state new-state)) - (define/public (get-state) state) - event-method - ...)) + (define state #f) + (define/public (set-state state%) + (set! state (new state% [machine this]))) + (define/public (get-state) + (send state get-state)) - (new machine%)))])) + (compile-proxy-methods (e ... ...) state) -(begin-for-syntax - (define (unique-event-names evt-stxs) - (remove-duplicates (map event-name (syntax->list evt-stxs)) - (lambda (a b) (eq? (syntax->datum a) (syntax->datum b))))) + (send this set-state initial-state) + (super-new))) - (define (event-name e) - (syntax-parse e - [(on (name . _) . _) #'name]))) - -(begin-for-syntax - ; Identifier (listof Syntax) -> Syntax - (define (compile-event-method event-name state-specs) - (define/syntax-parse (state-name ...) - (for/list ([state-spec state-specs]) - (state-spec-name state-spec))) - (define/syntax-parse (state-spec ...) state-specs) - #`(define/public (#,event-name . args) - (match (send this get-state) - ['state-name - (apply (compile-event-handler-for-state #,event-name state-name (state-spec ...)) - args)] - ... - [state (error 'machine (format "Unknown state: ~a" state))])))) - -(define-syntax compile-event-handler-for-state - (syntax-parser - [(_ event-name state-name (state-spec ...)) - (define/syntax-parse - ((on (_ arg ...) (~optional (~seq #:when guard) #:defaults ([guard #'#t])) - (goto next-state-name)) - ...) - (get-transitions-for-event-and-state #'event-name #'state-name #'(state-spec ...))) - #'(lambda args - (cond - [(apply (lambda (arg ...) guard) - args) - (send this set-state! 'next-state-name)] + (define state-name + (class object% + (init-field machine) + (define/public (get-state) + 'state-name) + action ... + (compile-event-method e machine) ... + (super-new))) ... - [else (error 'machine - "No transition defined for event ~v in state ~v" - (syntax->datum #'event-name) - (syntax->datum #'state-name))]))])) -(begin-for-syntax - ; Identifier Identifier (listof Syntax) -> (listof Syntax) - ; gets the transitions for the given event and state - (define (get-transitions-for-event-and-state evt-name state-name state-specs) - (apply append - (for/list ([state-spec (syntax->list state-specs)] - #:when (compiled-identifier=? (state-spec-name state-spec) - state-name)) - (syntax-parse state-spec - [(state _ - transition - ...) - (for/list ([transition (attribute transition)] - #:when (eq? (syntax->datum evt-name) - (syntax->datum (event-name transition)))) - transition)]))))) + (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) @@ -189,35 +167,6 @@ (state the-initial-state) (state unreachable))))) - (define turnstile - (machine - #:initial locked - - (state locked - (on (coin value) #:when (= value 0.25) - (goto unlocked)) - (on (coin value) - (goto locked))) - - (state unlocked - (on (person-enters) - (goto locked))))) - (check-equal? (send turnstile get-state) - 'locked) - (send turnstile coin 0.10) - (check-equal? (send turnstile get-state) - 'locked) - (send turnstile coin 0.25) - (check-equal? (send turnstile get-state) - 'unlocked) - (send turnstile person-enters) - (check-equal? (send turnstile get-state) - 'locked) - (check-exn - #rx"machine: No transition defined for event 'person-enters in state 'locked" - (lambda () - (send turnstile person-enters))) - (define-state-syntax simple-state (syntax-rules () [(_ name [evt next] ...) @@ -240,4 +189,21 @@ 'yellow) (send traffic-light tick) (check-equal? (send traffic-light get-state) - 'red)) + '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)))) From aec6580780bdee629ed9f59888112140b72a582d Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 27 Jun 2024 19:09:00 -0400 Subject: [PATCH 22/27] more general get-racket-references --- tests/racket-references.rkt | 70 +++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 tests/racket-references.rkt 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)) From 811e246a03f66ea6613e53276f849cf117396e6f Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 27 Jun 2024 19:10:02 -0400 Subject: [PATCH 23/27] symbol collection opaque structs, iterators --- main.rkt | 30 ++++++- private/ee-lib/main.rkt | 180 +++++++++++++++++++++++++++------------- 2 files changed, 152 insertions(+), 58 deletions(-) diff --git a/main.rkt b/main.rkt index 14852c8..8a0fe00 100644 --- a/main.rkt +++ b/main.rkt @@ -11,17 +11,43 @@ 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 - define-local-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) From 63ff3b5a0d8470490c73385d2253a71a1643fdb4 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 27 Jun 2024 19:11:10 -0400 Subject: [PATCH 24/27] state machine tutorial on-enter --- demos/minimal-state-machine/state-machine.rkt | 77 ++++++++++++++++++- scribblings/tutorial/basic-tutorial.scrbl | 2 +- tests/dsls/state-machine-for-tutorial.rkt | 6 +- 3 files changed, 78 insertions(+), 7 deletions(-) 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/scribblings/tutorial/basic-tutorial.scrbl b/scribblings/tutorial/basic-tutorial.scrbl index 283574e..4263a9a 100644 --- a/scribblings/tutorial/basic-tutorial.scrbl +++ b/scribblings/tutorial/basic-tutorial.scrbl @@ -18,7 +18,7 @@ We will: @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: +Here's what using the DSL to define a controller for a vending machine looks like: @(racketblock (define vending-machine diff --git a/tests/dsls/state-machine-for-tutorial.rkt b/tests/dsls/state-machine-for-tutorial.rkt index 226d0a7..d99b788 100644 --- a/tests/dsls/state-machine-for-tutorial.rkt +++ b/tests/dsls/state-machine-for-tutorial.rkt @@ -3,7 +3,7 @@ (provide (all-defined-out)) (require "../../testing.rkt" racket/class - (for-syntax racket/list)) + (for-syntax racket/pretty racket/list)) (syntax-spec (binding-class event-var) @@ -13,7 +13,7 @@ (nonterminal/exporting state-spec #:allow-extension state-macro - (state name:state-name ((~datum on-enter) body:racket-expr ...+) transition:transition-spec ...) + (state name:state-name ((~datum on-enter) body:racket-expr ...+) transition:transition-spec ...) #:binding (export name) (state name:state-name transition:transition-spec ...) @@ -44,7 +44,7 @@ ; Identifier (listof Syntax) -> SymbolSet (define (get-accessible-states initial-state-id state-specs) - (define-local-symbol-set accessible-states) + (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))) From 9860a4c7c692912ab60247806e776bc8f070c96e Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 27 Jun 2024 19:11:38 -0400 Subject: [PATCH 25/27] typo --- private/runtime/binding-operations.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/private/runtime/binding-operations.rkt b/private/runtime/binding-operations.rkt index 029e5cf..aece12d 100644 --- a/private/runtime/binding-operations.rkt +++ b/private/runtime/binding-operations.rkt @@ -98,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. @@ -128,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) . _) _) From 7f4571326858e0f7130618f00ecbe5c290458184 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 27 Jun 2024 19:12:29 -0400 Subject: [PATCH 26/27] stlc on typed racket --- tests/dsls/stlc-on-typed-racket.rkt | 116 ++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 tests/dsls/stlc-on-typed-racket.rkt 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)))) From a0a9858669bef3017a9a76adad9d2d0938c0b7f0 Mon Sep 17 00:00:00 2001 From: Mike Delmonaco Date: Thu, 27 Jun 2024 19:14:37 -0400 Subject: [PATCH 27/27] contract optimization in stlc --- scribblings/tutorial/stlc-tutorial.scrbl | 216 ++++++++++++++++++-- tests/dsls/simply-typed-lambda-calculus.rkt | 26 ++- 2 files changed, 211 insertions(+), 31 deletions(-) diff --git a/scribblings/tutorial/stlc-tutorial.scrbl b/scribblings/tutorial/stlc-tutorial.scrbl index 2a0f6fd..3d16d0f 100644 --- a/scribblings/tutorial/stlc-tutorial.scrbl +++ b/scribblings/tutorial/stlc-tutorial.scrbl @@ -3,16 +3,10 @@ @(require (for-label racket racket/block racket/class racket/match racket/list syntax/parse "../../main.rkt") scribble/example) -@title{Advanced Tutorial: Simply Typed Lambda Calculus} +@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. -We will: - -@itemlist[ -@;TODO -] - Here is an example program in our language: @racketblock[ @@ -78,16 +72,16 @@ Syntax-spec supports @tech[#:doc '(lib "scribblings/reference/reference.scrbl")] @racketblock[ (nonterminal typed-expr - ... + ... - (~> (e (~datum :) t) - #'(: e t)) - (: e:typed-expr t:type) + (~> (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. +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. @@ -277,6 +271,16 @@ Let's do it! ...) +(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) @@ -314,9 +318,7 @@ Let's do it! #`(contract #,(type->contract-stx (parse-type #'t)) e 'racket 'stlc - #f #'e)] - - ...)) + #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. @@ -325,7 +327,6 @@ This implementation is far from efficient. Instead of generating the syntax for Let's run some example programs now: - @examples[#:label #f (require syntax-spec/tests/dsls/simply-typed-lambda-calculus) (stlc/expr @@ -348,7 +349,182 @@ Let's run some example programs now: (rkt (app "not a function" 1) : Number)))) ] -@;TODO fix weird blame location +Our contract checks protect typed-untyped interactions. -@;TODO definitions, implicit block in let -@;TODO let* ? +@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 index c4fbf5b..d969b4f 100644 --- a/tests/dsls/simply-typed-lambda-calculus.rkt +++ b/tests/dsls/simply-typed-lambda-calculus.rkt @@ -42,7 +42,7 @@ (~> (fun arg ...) #'(#%app fun arg ...))) (nonterminal type - Number + (~datum Number) ((~datum ->) arg-type:type ... return-type:type)) (nonterminal/exporting typed-definition-or-expr #:allow-extension typed-macro @@ -130,7 +130,8 @@ ; Identifier Type -> Void ; Records the identifier's type. Does nothing if already recorded. (define (extend-type-environment! x t) - (void (symbol-table-ref types x (lambda () (symbol-table-set! types 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) @@ -183,15 +184,17 @@ ; inserts with-reference-compilers, and contract check (define-syntax compile-expr/top (syntax-parser - [(_ e t-stx) + [(_ 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))) - #`(contract #,(type->contract-stx t) - e^ - 'stlc 'racket - #f #'e)])) + (if (attribute should-skip-contract?) + #'e^ + #`(contract #,(type->contract-stx t) + e^ + 'stlc 'racket + #f #'e))])) (define-syntax compile-expr (syntax-parser @@ -238,11 +241,11 @@ (define-syntax compile-defn-or-expr/top (syntax-parser [(_ ((~datum #%define) x:id _ body)) - #`(define x (compile-expr/top body #,(get-identifier-type #'x)))] + #`(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))])) + #`(compile-expr/top e #,(infer-expr-type #'e) #t)])) (define-syntax compile-defn-or-expr (syntax-parser @@ -279,10 +282,11 @@ (syntax-parser [(_ x:id (~datum :) t e) #'(#%define x t e)] - [(_ (f:id [arg:id (~datum :) arg-type] ...) (~datum ->) return-type body) + [(_ (f:id [arg:id (~datum :) arg-type] ...) (~datum ->) return-type body ...) #'(#%define f (-> arg-type ... return-type) (lambda ([arg : arg-type] ...) - body))])) + body + ...))])) ; testing