├── .gitignore ├── objects ├── class.rkt ├── point-class.rkt ├── point-raw.rkt ├── point-send.rkt ├── point-with-method.rkt ├── raw.rkt ├── send.rkt ├── solutions │ ├── class.rkt │ ├── send.rkt │ └── with-method.rkt └── with-method.rkt ├── outline.txt └── ql ├── color-lexer.rkt ├── form-1.rkt ├── gui.rkt ├── has-type.rkt ├── house-4.rkt ├── house-5.rkt ├── house-6.rkt ├── house-7.rkt ├── house-raw-1.rkt ├── house-raw-2.rkt ├── house-raw-3.rkt ├── house-raw.rkt ├── house-t1.rkt ├── house-t2.rkt ├── house.ql ├── house.rkt ├── ops.rkt ├── parser.rkt ├── reader.rkt └── solutions ├── form-1.rkt ├── form-2.rkt ├── form-3.rkt ├── form-4.rkt ├── form-5.rkt ├── form-6.rkt ├── form-7.rkt ├── form-t1.rkt ├── form-t2.rkt └── main.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | doc/ 3 | *~ 4 | -------------------------------------------------------------------------------- /objects/class.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (rename-in "with-method.rkt" 3 | [class raw:class])) 4 | 5 | (provide class 6 | make-object 7 | send 8 | with-method) 9 | 10 | ;; >>> define `class` <<< 11 | ;; where the expansion uses `raw:class` 12 | -------------------------------------------------------------------------------- /objects/point-class.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "class.rkt" 3 | racket/math) 4 | 5 | (define point-class 6 | (class [x y] ; fields 7 | this ; name that refers back to self 8 | (define (get-x) x) 9 | (define (get-y) y) 10 | (define (set-x v) (set! x v)) 11 | (define (set-y v) (set! y v)) 12 | (define (rotate degrees) 13 | (define pt (make-rectangular x y)) 14 | (define new-pt (make-polar 15 | (magnitude pt) 16 | (+ (angle pt) (* pi (/ degrees 180))))) 17 | (set! x (real-part new-pt)) 18 | (set! y (imag-part new-pt))))) 19 | 20 | (define a-pt (make-object point-class 0 5)) 21 | 22 | (send a-pt set-x 10) 23 | (send a-pt rotate 90) 24 | (send a-pt get-x) 25 | (send a-pt get-y) 26 | 27 | 28 | -------------------------------------------------------------------------------- /objects/point-raw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "raw.rkt" 3 | racket/math) 4 | 5 | (define point-class 6 | (class 7 | (hash 'get-x 8 | (lambda (this) (get-field this 'x)) 9 | 'get-y 10 | (lambda (this) (get-field this 'y)) 11 | 'set-x 12 | (lambda (this v) (set-field! this 'x v)) 13 | 'set-y 14 | (lambda (this v) (set-field! this 'y v)) 15 | 'rotate 16 | (lambda (this degrees) 17 | (define pt (make-rectangular 18 | (get-field this 'x) 19 | (get-field this 'y))) 20 | (define new-pt (make-polar 21 | (magnitude pt) 22 | (+ (angle pt) (* pi (/ degrees 180))))) 23 | (set-field! this 'x (real-part new-pt)) 24 | (set-field! this 'y (imag-part new-pt)))) 25 | (hash 'x 0 26 | 'y 1))) 27 | 28 | (define a-pt (make-object point-class 0 5)) 29 | 30 | ((lookup-method a-pt 'set-x) a-pt 10) 31 | ((lookup-method a-pt 'rotate) a-pt 90) 32 | ((lookup-method a-pt 'get-x) a-pt) 33 | ((lookup-method a-pt 'get-y) a-pt) 34 | 35 | -------------------------------------------------------------------------------- /objects/point-send.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "send.rkt" 3 | racket/math) 4 | 5 | (define point-class 6 | (class 7 | (hash 'get-x 8 | (lambda (this) (get-field this 'x)) 9 | 'get-y 10 | (lambda (this) (get-field this 'y)) 11 | 'set-x 12 | (lambda (this v) (set-field! this 'x v)) 13 | 'set-y 14 | (lambda (this v) (set-field! this 'y v)) 15 | 'rotate 16 | (lambda (this degrees) 17 | (define pt (make-rectangular 18 | (get-field this 'x) 19 | (get-field this 'y))) 20 | (define new-pt (make-polar 21 | (magnitude pt) 22 | (+ (angle pt) (* pi (/ degrees 180))))) 23 | (set-field! this 'x (real-part new-pt)) 24 | (set-field! this 'y (imag-part new-pt)))) 25 | (hash 'x 0 26 | 'y 1))) 27 | 28 | (define a-pt (make-object point-class 0 5)) 29 | 30 | (send a-pt set-x 10) 31 | (send a-pt rotate 90) 32 | (send a-pt get-x) 33 | (send a-pt get-y) 34 | -------------------------------------------------------------------------------- /objects/point-with-method.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "with-method.rkt" 3 | racket/math) 4 | 5 | (define point-class 6 | (class 7 | (hash 'get-x 8 | (lambda (this) (get-field this 'x)) 9 | 'get-y 10 | (lambda (this) (get-field this 'y)) 11 | 'set-x 12 | (lambda (this v) (set-field! this 'x v)) 13 | 'set-y 14 | (lambda (this v) (set-field! this 'y v)) 15 | 'rotate 16 | (lambda (this degrees) 17 | (define pt (make-rectangular 18 | (get-field this 'x) 19 | (get-field this 'y))) 20 | (define new-pt (make-polar 21 | (magnitude pt) 22 | (+ (angle pt) (* pi (/ degrees 180))))) 23 | (set-field! this 'x (real-part new-pt)) 24 | (set-field! this 'y (imag-part new-pt)))) 25 | (hash 'x 0 26 | 'y 1))) 27 | 28 | (define a-pt (make-object point-class 0 5)) 29 | 30 | (send a-pt set-x 10) 31 | (send a-pt rotate 90) 32 | (send a-pt get-x) 33 | (send a-pt get-y) 34 | 35 | (define N 100000) 36 | 37 | (time 38 | (for ([i (in-range N)]) 39 | (send a-pt rotate 1))) 40 | 41 | (time 42 | (with-method ([rot (a-pt rotate)]) 43 | (for ([i (in-range N)]) 44 | (rot 1)))) 45 | -------------------------------------------------------------------------------- /objects/raw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide class 4 | make-object 5 | get-field 6 | set-field! 7 | lookup-method) 8 | 9 | (struct class (methods ; (hashof symbol (object any ... -> any)) 10 | field-positions)) ; (hashof symbol integer) 11 | 12 | (struct object (class ; class 13 | [fields #:mutable])) ; (vectorof any) 14 | 15 | (define (make-object c . args) 16 | (object c (list->vector args))) 17 | 18 | (define (get-field o name) 19 | (vector-ref (object-fields o) 20 | (hash-ref (class-field-positions (object-class o)) name))) 21 | 22 | (define (set-field! o name v) 23 | (vector-set! (object-fields o) 24 | (hash-ref (class-field-positions (object-class o)) name) 25 | v)) 26 | 27 | (define (lookup-method o name) 28 | (hash-ref (class-methods (object-class o)) name)) 29 | -------------------------------------------------------------------------------- /objects/send.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "raw.rkt" 3 | (for-syntax racket/base 4 | syntax/parse)) 5 | 6 | (provide class 7 | make-object 8 | get-field 9 | set-field! 10 | send) 11 | 12 | ;; >>> define `send` <<< 13 | 14 | -------------------------------------------------------------------------------- /objects/solutions/class.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (rename-in "with-method.rkt" 3 | [class raw:class])) 4 | 5 | (provide class 6 | make-object 7 | send 8 | with-method) 9 | 10 | (define-syntax class 11 | (syntax-rules (define) 12 | [(_ [field-name ...] 13 | this-id 14 | (define (method-name arg ...) body ...) 15 | ...) 16 | (raw:class 17 | (for/hash ([name '(method-name ...)] 18 | [proc (list (lambda (this-id arg ...) 19 | (define-field field-name this-id) 20 | ... 21 | body ...) 22 | ...)]) 23 | (values name proc)) 24 | (for/hash ([name '(field-name ...)] 25 | [pos (in-naturals)]) 26 | (values name pos)))])) 27 | 28 | (define-syntax-rule (define-field field-name this-id) 29 | (define-syntax field-name 30 | (syntax-id-rules (set!) 31 | [(set! id v) 32 | (set-field! this-id 'field-name v)] 33 | [(id arg (... ...)) 34 | ((get-field this-id 'field-name) arg (... ...))] 35 | [id 36 | (get-field this-id 'field-name)]))) 37 | -------------------------------------------------------------------------------- /objects/solutions/send.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "raw.rkt" 3 | (for-syntax racket/base 4 | syntax/parse)) 5 | 6 | (provide class 7 | make-object 8 | get-field 9 | set-field! 10 | send) 11 | 12 | ;; Solution to 1: 13 | 14 | (define-syntax-rule (send obj method-name arg ...) 15 | ((lookup-method obj 'method-name) obj arg ...)) 16 | 17 | ;; Solution to 2 (replaces above): 18 | #; 19 | (define-syntax send 20 | (lambda (stx) 21 | (syntax-parse stx 22 | [(_ obj method-name arg ...) 23 | (unless (identifier? #'method-name) 24 | (raise-syntax-error #f "not an identifier" #'method-name)) 25 | #'((lookup-method obj 'method-name) obj arg ...)]))) 26 | -------------------------------------------------------------------------------- /objects/solutions/with-method.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "send.rkt" 3 | (only-in "raw.rkt" lookup-method)) 4 | 5 | (provide class 6 | make-object 7 | get-field 8 | set-field! 9 | send 10 | with-method) 11 | 12 | (define-syntax-rule (with-method ([name (obj-expr method-name)]) 13 | body ...) 14 | (let ([obj obj-expr]) 15 | (let ([method (lookup-method obj 'method-name)]) 16 | (let-syntax ([name 17 | (syntax-rules () 18 | [(_ arg (... ...)) 19 | (method obj arg (... ...))])]) 20 | body ...)))) 21 | 22 | 23 | -------------------------------------------------------------------------------- /objects/with-method.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "send.rkt" 3 | (only-in "raw.rkt" lookup-method)) 4 | 5 | (provide class 6 | make-object 7 | get-field 8 | set-field! 9 | send 10 | with-method) 11 | 12 | ;; >>> define `with-method` <<< 13 | -------------------------------------------------------------------------------- /outline.txt: -------------------------------------------------------------------------------- 1 | 2 | Show QL end product 3 | 4 | ---------------------------------------- 5 | 6 | Intro to Racket: [30 min] 7 | 8 | #lang racket 9 | 10 | numbers, strings, booleans 11 | 12 | define 13 | 14 | lambda 15 | 16 | map, etc. 17 | 18 | struct 19 | 20 | [for, class, etc.] 21 | 22 | ---------------------- 23 | 24 | modules, require, provide 25 | 26 | ---------------------- 27 | 28 | quote 29 | 30 | #', syntax-e, datum->syntax, identifier? 31 | 32 | define-syntax 33 | 34 | syntax-parse 35 | 36 | syntax-rules (with literals), define-syntax-rule 37 | 38 | let-syntax 39 | 40 | ---------------------- 41 | 42 | macros that expand to definitions; `begin` splicing 43 | 44 | ---------------------------------------- 45 | 46 | Practice: [30 min] 47 | 48 | Start with the run-time core for an object system. 49 | 50 | In the "objects" directory, 51 | "raw.rkt" implements classes and objects; 52 | "point-raw.rkt" uses it for a point class. 53 | 54 | 1. Implement `send` via `define-syntax-rule`. 55 | 56 | The "point-send.rkt" use shows how `send` should 57 | work. You implement "send.rkt" by importing "raw.rkt" 58 | and re-exporting some parts, while also adding 59 | `define-syntax-rule` 60 | 61 | 2. Change `send` to statically check for an identifier 62 | 63 | For example, 64 | (send a-pt 10) 65 | 66 | should produce a syntax error instead of a "no value for key" 67 | run-time error. 68 | 69 | Start by changing `define-syntax-rule` to use `define-syntax` plus 70 | a function, plus `syntax-parse`. You'll need to import 71 | `racket/base` and `syntax/parse` for compile-time use. The 72 | `identifier?` and `raise-syntax-error` functions will be handy. 73 | 74 | Hint: 75 | (unless (identifier? ....) 76 | (raise-syntax-error #f "not an identifier" ....)) 77 | 78 | 3. Implement `with-method`. 79 | 80 | The "point-with-method.rkt" use shows how `with-method` should 81 | work. As a first cut, it's ok to make `with-method` work only when 82 | exactly one argument is provided. 83 | 84 | Hint: the `with-method` macro is easiest to implement using 85 | `let-syntax` to locally bind a name as a macro. 86 | 87 | 4. [Challenge] Implement `class`. 88 | 89 | The "point-class.rkt" use shows how `class` should work. 90 | 91 | Hint: the `syntax-id-rules` form is like `syntax-rules`, but an 92 | "identifier macro" created with `syntax-id-rules` is triggered 93 | even when an identifier is used by itself (i.e., not after an open 94 | parenthesis) or when it is used with `set!`. The `class` form 95 | should bind field names as identifier macros, so uses or 96 | assignemnts of fields can be transformed to use `get-field` and 97 | `set-field!`. 98 | 99 | ---------------------------------------- 100 | 101 | QL, part 1: [1 hour] 102 | 103 | In "ql", "house.ql" should our ultimate target, while "house.rkt" 104 | shows a parenthesized form of the language that we'll build up to 105 | first. 106 | 107 | The "gui.rkt" and "ops.rkt" modules are effectively the runtime 108 | system for QL. The "house-raw.rkt" module uses those directly to 109 | produce the same result as "house.rkt". We'll write macros that 110 | implement "house.rkt" as "house-raw.rkt". 111 | 112 | 1. Implement `form` without guards or computed field values (which no 113 | particular syntax checks, for now). 114 | 115 | The "house-raw-1.rkt" module provides a small example of what this 116 | version should express. The commented-out part should be at the 117 | end of a new "form-1.rkt" module, which you implement by importing 118 | "gui.rkt" and "op.rkt" and defining `form`. 119 | 120 | Hint: Use a `form-clause` helper macro. 121 | 122 | 2. Support an optional expression to compute a field's value. 123 | 124 | The "house-raw-2.rkt" module provides a small example of what this 125 | version should express. 126 | 127 | Hint: Change your `form-clause` helper to `form-clause*` with no 128 | optional parts, and define a new `form-clause` with multiple 129 | patterns that use `form-clause*`. 130 | 131 | 3. Add support for guarded clauses via `when`. 132 | 133 | See "house-raw-3.rkt". 134 | 135 | Hint: The `form-clause` macro could use itself, especially if a 136 | guard expression is threaded through. 137 | 138 | Are guard expressions duplicated by your macros? 139 | 140 | 4. Split the language implementation from use. 141 | 142 | Instead of a "form-4.rkt" that has both the macros and the use, 143 | have "form-4.rkt" be just the macros, and define "house-4.rkt" by 144 | importing from "form-4.rkt". 145 | 146 | 5. [Together] Turn the `form` module into a language. 147 | 148 | See "house-5.rkt". 149 | 150 | 6. Syntactically check that form has an identifier, and check that 151 | each clause has an identifier and a question string. 152 | 153 | See "house-6.rkt". 154 | 155 | 7. Constrain `when` use so that it is allowed only for guarding 156 | clauses. 157 | 158 | See "house-7.rkt". 159 | 160 | Hint: export a `when*` as `when`, where `when*` always rasies 161 | a syntax error 162 | 163 | ---------------------------------------- 164 | 165 | QL, part 2: [1 hour] 166 | 167 | Overview of a type-checking idea 168 | 169 | modules and phases 170 | 171 | syntax-local-value 172 | 173 | local-expand 174 | 175 | 1. Insert type declaration & checking uses, given `typed`, 176 | `has-type`, `check-type`, and `datum`. 177 | 178 | See "house-t1.rkt". The "has-type.rkt" module implements the basic 179 | type-checking idea. 180 | 181 | For now, operators do not yet have types, so they can't be used. 182 | 183 | 2. Add types for operators. 184 | 185 | See "house-t2.rkt". 186 | 187 | Hint: Define `-/typed`, `>/typed`, etc., as replacements for 188 | `-/coerce`, etc. 189 | 190 | -------------------- 191 | 192 | Non-S-expression languages and DrRacket 193 | 194 | 3. Given a reader, implement "main.rkt", and link the "ql" 195 | collection. 196 | 197 | The "reader.rkt" module provides suitable `read` and `read-syntax` 198 | functions. 199 | 200 | 4. [Together] Given `color-lexer`, add it to "main.rkt". 201 | 202 | The "color-lexer.rkt" module provides `color-lexer`. 203 | 204 | ---------------------------------------- 205 | 206 | Homework: 207 | 208 | 1. Add an `if` form for use in guards or expressions to compute field 209 | values. 210 | 211 | 2. Add a `text` field type, where "gui.rkt" already provides 212 | `text-widget`. 213 | 214 | You can pick any of the QL solutions as a starting point, but one with 215 | at least type checking will be the most interesting, and the one with 216 | non-S-expression syntax should be within reach. 217 | -------------------------------------------------------------------------------- /ql/color-lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require parser-tools/lex 3 | "parser.rkt") 4 | 5 | ;; Environment support for token coloring 6 | 7 | (provide color-lexer) 8 | 9 | (define (color-lexer in offset mode) 10 | ;; Get next token: 11 | (define tok (lex in)) 12 | ;; Package classification with srcloc: 13 | (define (ret mode paren [eof? #f]) 14 | (values (if eof? 15 | eof 16 | (token->string (position-token-token tok) 17 | (token-value (position-token-token tok)))) 18 | mode 19 | paren 20 | (position-offset (position-token-start-pos tok)) 21 | (position-offset (position-token-end-pos tok)) 22 | 0 23 | #f)) 24 | ;; Convert token to classification: 25 | (case (token-name (position-token-token tok)) 26 | [(EOF) (ret 'eof #f #t)] 27 | [(BOPEN) (ret 'parenthesis '|{|)] 28 | [(BCLOSE) (ret 'parenthesis '|}|)] 29 | [(OPEN) (ret 'parenthesis '|(|)] 30 | [(CLOSE) (ret 'parenthesis '|)|)] 31 | [(NUM) (ret 'constant #f)] 32 | [(STRING) (ret 'constant #f)] 33 | [(ID) (ret 'symbol #f)] 34 | [(WHITESPACE) (ret 'white-space #f)] 35 | [(ERROR) (ret 'error #f)] 36 | [else (ret 'other #f)])) 37 | 38 | -------------------------------------------------------------------------------- /ql/form-1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | ;; >>> define `form` <<< 6 | 7 | ; ---------------------------------------- 8 | 9 | (form Box1HouseOwning 10 | [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 11 | [sellingPrice "Price the house was sold for:" money-widget]) 12 | -------------------------------------------------------------------------------- /ql/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (provide make-gui 4 | gui-add! 5 | boolean-widget 6 | money-widget 7 | text-widget) 8 | 9 | ;; A GUI is represented by a `survey-frame%` object 10 | 11 | (define (make-gui name) 12 | (new survey-frame% 13 | [label (format "~s" name)])) 14 | 15 | (define survey-frame% 16 | (class frame% 17 | (inherit show) 18 | 19 | (define questions null) 20 | (define/public (add-question! q) 21 | (set! questions (cons q questions))) 22 | 23 | (define/public (react-all) 24 | (for ([c (reverse questions)]) 25 | (send c react))) 26 | 27 | (define/public (start) 28 | (react-all) 29 | (show #t) 30 | (yield (current-eventspace))) 31 | 32 | (super-new))) 33 | 34 | ;; ---------------------------------------- 35 | 36 | ;; An individual question is housed in a `question-panel%` 37 | 38 | (define (gui-add! frame widget question show? update! get-value) 39 | (define panel (new question-panel% 40 | [parent frame] 41 | [stretchable-height #f] 42 | [show? show?])) 43 | (new message% 44 | [parent panel] 45 | [label question]) 46 | (void (widget panel update! get-value))) 47 | 48 | (define question-panel% 49 | (class horizontal-panel% 50 | (inherit get-children) 51 | (init-field parent) 52 | (init-field show?) 53 | (send parent add-question! this) 54 | (define shown? #t) 55 | (define/public (react) 56 | (define s? (show?)) 57 | (unless (equal? s? shown?) 58 | (if s? 59 | (send parent add-child this) 60 | (send parent delete-child this)) 61 | (set! shown? s?)) 62 | (send (last (get-children)) react)) 63 | (define/public (react-all) 64 | (send parent react-all)) 65 | (super-new [parent parent]))) 66 | 67 | ;; ---------------------------------------- 68 | 69 | ;; Different datatypes corresponds to widgets that are used 70 | ;; within question-panel: 71 | 72 | (define (boolean-widget panel update! get-value) 73 | (new (class check-box% 74 | (define/public (react) 75 | (when get-value 76 | (send this set-value (get-value)))) 77 | (super-new)) 78 | [parent panel] 79 | [label ""] 80 | [callback (lambda (c e) 81 | (update! (send c get-value)) 82 | (send panel react-all))])) 83 | 84 | (define (money-widget panel update! get-value) 85 | (new (class text-field% 86 | (define/public (react) 87 | (when get-value 88 | (define n (get-value)) 89 | (send this set-value (if (number? n) (~a n) "")))) 90 | (super-new)) 91 | [parent panel] 92 | [label #f] 93 | [callback (lambda (t e) 94 | (update! (string->number (send t get-value))) 95 | (send panel react-all))])) 96 | 97 | (define (text-widget panel update! get-value) 98 | (new (class text-field% 99 | (define/public (react) 100 | (when get-value 101 | (define n (get-value)) 102 | (send this set-value (if (string? n) n "")))) 103 | (super-new)) 104 | [parent panel] 105 | [label #f] 106 | [callback (lambda (t e) 107 | (update! (send t get-value)) 108 | (send panel react-all))])) 109 | -------------------------------------------------------------------------------- /ql/has-type.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (for-syntax syntax/parse)) 3 | 4 | (provide define-typed 5 | has-type 6 | check-type) 7 | 8 | (begin-for-syntax 9 | (define (typed id type) 10 | (lambda (stx) 11 | (if (identifier? stx) 12 | #`(has-type #,id #,type) 13 | (raise-syntax-error 14 | #f 15 | "cannot use variable as a function" 16 | stx))))) 17 | 18 | (define-syntax define-typed 19 | (lambda (stx) 20 | (syntax-parse stx 21 | [(define-typed id val-id type) 22 | (unless (identifier? #'id) 23 | (raise-syntax-error #f 24 | "expected an identifier" 25 | #'id)) 26 | (unless (identifier? #'val-id) 27 | (raise-syntax-error #f 28 | "expected an identifier that holds the value" 29 | #'val-id)) 30 | #'(define-syntax id (typed #'val-id #'type))]))) 31 | 32 | (define-syntax-rule (has-type expr type) 33 | expr) 34 | 35 | (define-syntax check-type 36 | (lambda (stx) 37 | (syntax-parse stx 38 | [(_ expr expected-type) 39 | (let ([expr2 (local-expand #'expr 40 | 'expression 41 | (list #'has-type))]) 42 | (syntax-parse expr2 #:literals (has-type) 43 | [(has-type v type) 44 | (unless (equal? (syntax-e #'type) 45 | (syntax-e #'expected-type)) 46 | (raise-syntax-error 47 | 'form 48 | (format "expected type ~a, found type ~a" 49 | (syntax-e #'expected-type) 50 | (syntax-e #'type)) 51 | #'expr)) 52 | expr2] 53 | [_ 54 | (raise-syntax-error 55 | 'form 56 | (format "expected type ~a, found expression of unknown type" 57 | (syntax-e #'expected-type)) 58 | #'expr)]))]))) 59 | -------------------------------------------------------------------------------- /ql/house-4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "form-4.rkt") 3 | 4 | (form Box1HouseOwning 5 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 6 | (when hasSoldHouse 7 | [sellingPrice "Price the house was sold for:" money] 8 | [privateDebt "Private debts for the sold house:" money] 9 | [valueResidue "Value residue:" money (- sellingPrice privateDebt)])) 10 | -------------------------------------------------------------------------------- /ql/house-5.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "form-5.rkt" 2 | 3 | (form Box1HouseOwning 4 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 5 | (when hasSoldHouse 6 | [sellingPrice "Price the house was sold for:" money] 7 | [privateDebt "Private debts for the sold house:" money] 8 | [valueResidue "Value residue:" money (- sellingPrice privateDebt)])) 9 | -------------------------------------------------------------------------------- /ql/house-6.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "form-6.rkt" 2 | 3 | (form Box1HouseOwning ; <-- adding quotes should provoke a clear error 4 | ;; extra parens around first or second part of the next clause 5 | ;; should give a good error, too: 6 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 7 | (when hasSoldHouse 8 | [sellingPrice "Price the house was sold for:" money] 9 | [privateDebt "Private debts for the sold house:" money] 10 | [valueResidue "Value residue:" money (- sellingPrice privateDebt)])) 11 | -------------------------------------------------------------------------------- /ql/house-7.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "form-7.rkt" 2 | 3 | (form Box1HouseOwning 4 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 5 | (when hasSoldHouse 6 | [sellingPrice "Price the house was sold for:" money] 7 | [privateDebt "Private debts for the sold house:" money] 8 | [valueResidue "Value residue:" money 9 | ;; Using `when` here should not work: 10 | (- sellingPrice privateDebt)])) 11 | -------------------------------------------------------------------------------- /ql/house-raw-1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | ;(form Box1HouseOwning 6 | ; [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 7 | ; [sellingPrice "Price the house was sold for:" money-widget]) 8 | 9 | (define Box1HouseOwning 10 | (make-gui 'Box1HouseOwning)) 11 | 12 | (define hasSoldHouse undefined) 13 | (gui-add! Box1HouseOwning 14 | boolean-widget 15 | "Did you sell a house in 2010?" 16 | (lambda () #t) ; guard 17 | (lambda (v) (set! hasSoldHouse v)) 18 | #f) ; not a computed field 19 | 20 | (define sellingPrice undefined) 21 | (gui-add! Box1HouseOwning 22 | money-widget 23 | "Price the house was sold for:" 24 | (lambda () #t) ; guard 25 | (lambda (v) (set! sellingPrice v)) 26 | #f) ; not a computed field 27 | 28 | (send Box1HouseOwning start) 29 | -------------------------------------------------------------------------------- /ql/house-raw-2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | ;(form Box1HouseOwning 6 | ; [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 7 | ; [sellingPrice "Price the house was sold for:" money-widget] 8 | ; [privateDebt "Private debts for the sold house:" money-widget] 9 | ; [valueResidue "Value residue:" money-widget (-/coerce sellingPrice privateDebt)]) 10 | 11 | (define Box1HouseOwning 12 | (make-gui 'Box1HouseOwning)) 13 | 14 | (define hasSoldHouse undefined) 15 | (gui-add! Box1HouseOwning 16 | boolean-widget 17 | "Did you sell a house in 2010?" 18 | (lambda () #t) ; guard 19 | (lambda (v) (set! hasSoldHouse v)) 20 | #f) ; not a computed field 21 | 22 | (define sellingPrice undefined) 23 | (gui-add! Box1HouseOwning 24 | money-widget 25 | "Price the house was sold for:" 26 | (lambda () #t) 27 | (lambda (v) (set! sellingPrice v)) 28 | #f) 29 | 30 | (define privateDebt undefined) 31 | (gui-add! Box1HouseOwning 32 | money-widget 33 | "Private debts for the sold house:" 34 | (lambda () #t) 35 | (lambda (v) (set! privateDebt v)) 36 | #f) 37 | 38 | (define valueResidue undefined) 39 | (gui-add! Box1HouseOwning 40 | money-widget 41 | "Value residue:" 42 | (lambda () #t) 43 | (lambda (v) (set! valueResidue v)) 44 | (lambda () (-/coerce sellingPrice privateDebt))) 45 | 46 | (send Box1HouseOwning start) 47 | -------------------------------------------------------------------------------- /ql/house-raw-3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | ;(form Box1HouseOwning 6 | ; [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 7 | ; (when hasSoldHouse 8 | ; [sellingPrice "Price the house was sold for:" money-widget] 9 | ; [privateDebt "Private debts for the sold house:" money-widget] 10 | ; [valueResidue "Value residue:" money-widget (-/coerce sellingPrice privateDebt)])) 11 | 12 | (define Box1HouseOwning 13 | (make-gui 'Box1HouseOwning)) 14 | 15 | (define hasSoldHouse undefined) 16 | (gui-add! Box1HouseOwning 17 | boolean-widget 18 | "Did you sell a house in 2010?" 19 | (lambda () #t) ; guard 20 | (lambda (v) (set! hasSoldHouse v)) 21 | #f) ; not a computed field 22 | 23 | (define sellingPrice undefined) 24 | (gui-add! Box1HouseOwning 25 | money-widget 26 | "Price the house was sold for:" 27 | (lambda () (?/coerce hasSoldHouse)) ; <--------------- 28 | (lambda (v) (set! sellingPrice v)) 29 | #f) 30 | 31 | (define privateDebt undefined) 32 | (gui-add! Box1HouseOwning 33 | money-widget 34 | "Private debts for the sold house:" 35 | (lambda () (?/coerce hasSoldHouse)) ; <--------------- 36 | (lambda (v) (set! privateDebt v)) 37 | #f) 38 | 39 | (define valueResidue undefined) 40 | (gui-add! Box1HouseOwning 41 | money-widget 42 | "Value residue:" 43 | (lambda () (?/coerce hasSoldHouse)) ; <--------------- 44 | (lambda (v) (set! valueResidue v)) 45 | (lambda () (-/coerce sellingPrice privateDebt))) 46 | 47 | (send Box1HouseOwning start) 48 | -------------------------------------------------------------------------------- /ql/house-raw.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | ;(form Box1HouseOwning 6 | ; [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 7 | ; [hasBoughtHouse "Did you buy a house in 2010?" boolean-widget] 8 | ; [hasMaintLoan "Did you enter a loan for maintenance/reconstruction?" boolean-widget] 9 | ; 10 | ; (when hasSoldHouse 11 | ; [sellingPrice "Price the house was sold for:" money-widget] 12 | ; [privateDebt "Private debts for the sold house:" money-widget] 13 | ; [valueResidue "Value residue:" money-widget (-/coerce sellingPrice privateDebt)])) 14 | 15 | (define Box1HouseOwning 16 | (make-gui 'Box1HouseOwning)) 17 | 18 | (define hasSoldHouse undefined) 19 | (gui-add! Box1HouseOwning 20 | boolean-widget 21 | "Did you sell a house in 2010?" 22 | (lambda () #t) ; guard 23 | (lambda (v) (set! hasSoldHouse v)) 24 | #f) ; not a computed field 25 | 26 | (define hasBoughtHouse undefined) 27 | (gui-add! Box1HouseOwning 28 | boolean-widget 29 | "Did you buy a house in 2010?" 30 | (lambda () #t) 31 | (lambda (v) (set! hasBoughtHouse v)) 32 | #f) 33 | 34 | (define hasMaintLoan undefined) 35 | (gui-add! Box1HouseOwning 36 | boolean-widget 37 | "Did you buy a house in 2010?" 38 | (lambda () #t) ; guard 39 | (lambda (v) (set! hasMaintLoan v)) 40 | #f) 41 | 42 | (define sellingPrice undefined) 43 | (gui-add! Box1HouseOwning 44 | money-widget 45 | "Price the house was sold for:" 46 | (lambda () (?/coerce hasSoldHouse)) ; guard 47 | (lambda (v) (set! sellingPrice v)) 48 | #f) 49 | 50 | (define privateDebt undefined) 51 | (gui-add! Box1HouseOwning 52 | money-widget 53 | "Private debts for the sold house:" 54 | (lambda () (?/coerce hasSoldHouse)) 55 | (lambda (v) (set! privateDebt v)) 56 | #f) 57 | 58 | (define valueResidue undefined) 59 | (gui-add! Box1HouseOwning 60 | money-widget 61 | "Value residue:" 62 | (lambda () (?/coerce hasSoldHouse)) 63 | (lambda (v) (set! valueResidue v)) 64 | (lambda () (-/coerce sellingPrice privateDebt))) 65 | 66 | (send Box1HouseOwning start) 67 | -------------------------------------------------------------------------------- /ql/house-t1.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "form-t1.rkt" 2 | 3 | (form Box1HouseOwning 4 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 5 | (when hasSoldHouse ; <- using `sellingPrice` here should be a type error 6 | [sellingPrice "Price the house was sold for:" money] 7 | [privateDebt "Private debts for the sold house:" money] 8 | [valueResidue "Value residue:" money 9 | ;; `hasSoldHouse` here should be a type error: 10 | sellingPrice])) 11 | -------------------------------------------------------------------------------- /ql/house-t2.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "form-t2.rkt" 2 | 3 | (form Box1HouseOwning 4 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 5 | (when hasSoldHouse ; <- using `sellingPrice` here should be a type error 6 | [sellingPrice "Price the house was sold for:" money] 7 | [privateDebt "Private debts for the sold house:" money] 8 | [valueResidue "Value residue:" money 9 | ;; `hasSoldHouse` here should be a type error: 10 | (- sellingPrice privateDebt)])) 11 | -------------------------------------------------------------------------------- /ql/house.ql: -------------------------------------------------------------------------------- 1 | #lang reader "reader.rkt" 2 | 3 | form Box1HouseOwning { 4 | hasSoldHouse: "Did you sell a house in 2010?" boolean 5 | hasBoughtHouse: "Did you by a house in 2010?" boolean 6 | hasMaintLoan: "Did you enter a loan for maintenance/reconstruction?" boolean 7 | 8 | if (hasSoldHouse) { 9 | sellingPrice: "Price the house was sold for:" money 10 | privateDebt: "Private debts for the sold house:" money 11 | valueResidue: "Value residue:" money(sellingPrice - privateDebt) 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /ql/house.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp "form-t2.rkt" 2 | 3 | (form Box1HouseOwning 4 | [hasSoldHouse "Did you sell a house in 2010?" boolean] 5 | [hasBoughtHouse "Did you by a house in 2010?" boolean] 6 | [hasMaintLoan "Did you enter a loan for maintenance/reconstruction?" boolean] 7 | 8 | (when hasSoldHouse 9 | [sellingPrice "Price the house was sold for:" money] 10 | [privateDebt "Private debts for the sold house:" money] 11 | [valueResidue "Value residue:" money (- sellingPrice privateDebt)])) 12 | -------------------------------------------------------------------------------- /ql/ops.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide undefined 4 | ?/coerce 5 | -/coerce 6 | /coerce =/coerce 7 | and/coerce or/coerce 8 | provide-ops) 9 | 10 | ;; ---------------------------------------- 11 | 12 | (define undefined 'undefined) 13 | 14 | (define (?/coerce v) 15 | (cond 16 | [(eq? undefined v) #f] 17 | [else (and v #t)])) 18 | 19 | (define (-/coerce a b) 20 | (- (if (number? a) a 0) 21 | (if (number? b) b 0))) 22 | 23 | (define-syntax-rule (define-comp-coerce x/coerce x) 24 | (define (x/coerce a b) 25 | (and (number? a) 26 | (number? b) 27 | (x a b)))) 28 | (define-comp-coerce /coerce >) 30 | (define-comp-coerce =/coerce =) 31 | 32 | (define (and/coerce a b) (and (?/coerce a) (?/coerce b))) 33 | (define (or/coerce a b) (or (?/coerce a) (?/coerce b))) 34 | 35 | ;; ---------------------------------------- 36 | 37 | (define-syntax-rule (provide-ops) 38 | (provide (rename-out [-/coerce -] 39 | [>/coerce >] 40 | [string) 11 | 12 | (define (parse src-name in) 13 | (parameterize ([current-source src-name]) 14 | (parse-from-lex (lambda () 15 | ;; Discard whitespace from `lex`: 16 | (let loop () 17 | (let ([v (lex in)]) 18 | (if (eq? 'WHITESPACE (position-token-token v)) 19 | (loop) 20 | v))))))) 21 | 22 | ;; ---------------------------------------- 23 | ;; Lexer 24 | 25 | (define-tokens content-tokens 26 | (ID NUM BINOP STRING ERROR)) 27 | 28 | (define-empty-tokens delim-tokens 29 | (EOF FORM OPEN CLOSE BOPEN BCLOSE 30 | MINUS LESS GREATER EQUAL COLON 31 | AND OR IF 32 | BOOLEAN MONEY 33 | WHITESPACE)) 34 | 35 | (define lex 36 | (lexer-src-pos 37 | [(:or (:seq (:+ (:/ "0" "9")) (:? ".") (:* (:/ "0" "9"))) 38 | (:seq "." (:* (:/ "0" "9")))) 39 | (token-NUM (string->number lexeme))] 40 | [(:seq #\" (:* (:~ #\")) #\") 41 | (token-STRING (substring lexeme 1 (sub1 (string-length lexeme))))] 42 | ["{" 'BOPEN] 43 | ["}" 'BCLOSE] 44 | ["(" 'OPEN] 45 | [")" 'CLOSE] 46 | ["-" 'MINUS] 47 | ["<" 'LESS] 48 | [">" 'GREATER] 49 | ["=" 'EQUAL] 50 | [":" 'COLON] 51 | ["&&" 'AND] 52 | ["||" 'OR] 53 | ["if" 'IF] 54 | ["form" 'FORM] 55 | ["boolean" 'BOOLEAN] 56 | ["money" 'MONEY] 57 | [(:seq (:/ #\A #\Z #\a #\z) 58 | (:+ (:/ #\A #\Z #\a #\z #\0 #\9))) 59 | (token-ID (string->symbol lexeme))] 60 | [(:+ whitespace) 'WHITESPACE] 61 | [(eof) 'EOF] 62 | [any-char (token-ERROR lexeme)])) 63 | 64 | (define parse-from-lex 65 | (cfg-parser 66 | (start
) 67 | (end EOF) 68 | (tokens content-tokens 69 | delim-tokens) 70 | (precs) 71 | (error (lambda (a t v start end) 72 | (raise-parse-error t v start end))) 73 | (src-pos) 74 | (grammar 75 | ( [(FORM BOPEN BCLOSE) 76 | (at-src `(form ,$2 ,@$4))]) 77 | ( [() null] 78 | [( ) (cons $1 $2)]) 79 | ( [( COLON ) 80 | (at-src `[,$1 ,$3 ,$4])] 81 | [( COLON ) 82 | (at-src `[,$1 ,$3 ,$4 ,$5])] 83 | [(IF OPEN CLOSE BOPEN BCLOSE) 84 | (at-src `(when ,$3 ,@$6))]) 85 | ( [(STRING) (at-src $1)]) 86 | ( [(ID) (at-src $1)]) 87 | ( [(NUM) (at-src $1)] 88 | [() $1] 89 | [() $1] 90 | ;; [( ) (at-src `(,$1 ,$2))] 91 | [( ) (at-src `(,$2 ,$1 ,$3))] 92 | [(OPEN CLOSE) $2]) 93 | ( [(MINUS) (at-src '-)] 94 | [(LESS) (at-src '<)] 95 | [(GREATER) (at-src '>)] 96 | [(EQUAL) (at-src '=)] 97 | [(AND) (at-src 'and)] 98 | [(OR) (at-src 'or)]) 99 | ;; () 100 | ( [(BOOLEAN) (at-src 'boolean)] 101 | [(MONEY) (at-src 'money)])))) 102 | 103 | (define-syntax (at-src stx) 104 | (syntax-case stx () 105 | [(_ e) 106 | (with-syntax ([start (datum->syntax stx '$1-start-pos)] 107 | [end (datum->syntax stx '$n-end-pos)]) 108 | #'(datum->syntax #f e (to-srcloc start end) orig-prop))])) 109 | 110 | (define orig-prop (read-syntax 'src (open-input-bytes #"x"))) 111 | 112 | ;; ---------------------------------------- 113 | ;; Source locations and error reporting: 114 | 115 | (define current-source (make-parameter #f)) 116 | 117 | (define (to-srcloc start end) 118 | (list 119 | (current-source) 120 | (position-line start) 121 | (position-col start) 122 | (position-offset start) 123 | (and (position-offset end) 124 | (position-offset start) 125 | (- (position-offset end) 126 | (position-offset start))))) 127 | 128 | (define (raise-parse-error t v start end) 129 | (apply 130 | (if (eq? t 'EOF) raise-read-eof-error raise-read-error) 131 | (format "bad syntax at ~a" (token->string t v)) 132 | (to-srcloc start end))) 133 | 134 | (define (token->string t v) 135 | (if v 136 | (format "~a" v) 137 | (format "~a" t))) 138 | -------------------------------------------------------------------------------- /ql/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "parser.rkt") 3 | 4 | (provide read-syntax 5 | read) 6 | 7 | ;; To read a module: 8 | (define (read-syntax src-name in) 9 | (define stx (parse src-name in)) 10 | (let* ([p-name (object-name in)] 11 | [name (if (path? p-name) 12 | (let-values ([(base name dir?) (split-path p-name)]) 13 | (string->symbol 14 | (path->string (path-replace-suffix name #"")))) 15 | 'anonymous)]) 16 | (datum->syntax #f `(module ,name "form-t2.rkt" (#%module-begin ,stx))))) 17 | 18 | ;; In case `read' is used, instead of `read-syntax': 19 | (define (read in) 20 | (syntax->datum (read-syntax (object-name in) in))) 21 | -------------------------------------------------------------------------------- /ql/solutions/form-1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | (define-syntax-rule (form name clause ...) 6 | (begin 7 | (define name (make-gui 'name)) ; create a container 8 | (form-clause name clause) ... 9 | (send name start))) ; show the container 10 | 11 | (define-syntax-rule (form-clause form-name [id question type]) 12 | (begin 13 | (define id undefined) 14 | (gui-add! form-name ; container 15 | type ; widget 16 | question ; label 17 | (lambda () #t) ; guard 18 | (lambda (v) (set! id v)) ; set value 19 | #f))) 20 | 21 | ; ---------------------------------------- 22 | 23 | (form Box1HouseOwning 24 | [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 25 | [sellingPrice "Price the house was sold for:" money-widget]) 26 | -------------------------------------------------------------------------------- /ql/solutions/form-2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | (define-syntax-rule (form name clause ...) 6 | (begin 7 | (define name (make-gui 'name)) ; create a container 8 | (form-clause name clause) ... 9 | (send name start))) ; show the container 10 | 11 | (define-syntax form-clause 12 | (syntax-rules () 13 | [(_ form-name [id question type]) 14 | (form-clause* form-name [id question type #f])] 15 | [(_ form-name [id question type compute-expr]) 16 | (form-clause* form-name [id question type (lambda () compute-expr)])])) 17 | 18 | (define-syntax-rule (form-clause* form-name [id question type compute-expr]) 19 | (begin 20 | (define id undefined) 21 | (gui-add! form-name ; container 22 | type ; widget 23 | question ; label 24 | (lambda () #t) ;guard 25 | (lambda (v) (set! id v)) ; set value 26 | compute-expr))) 27 | 28 | ; ---------------------------------------- 29 | 30 | (form Box1HouseOwning 31 | [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 32 | [sellingPrice "Price the house was sold for:" money-widget] 33 | [privateDebt "Private debts for the sold house:" money-widget] 34 | [valueResidue "Value residue:" money-widget (-/coerce sellingPrice privateDebt)]) 35 | -------------------------------------------------------------------------------- /ql/solutions/form-3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | 5 | (define-syntax-rule (form name clause ...) 6 | (begin 7 | (define name (make-gui 'name)) ; create a container 8 | (form-clause name #t clause) ... 9 | (send name start))) ; show the container 10 | 11 | (define-syntax form-clause 12 | (syntax-rules (when) 13 | [(_ form-name guard-expr [id question type]) 14 | (form-clause* form-name guard-expr [id question type #f])] 15 | [(_ form-name guard-expr [id question type compute-expr]) 16 | (form-clause* form-name guard-expr [id question type (lambda () compute-expr)])] 17 | [(_ form-name guard-expr (when expr clause ...)) 18 | (begin 19 | (form-clause form-name (and guard-expr (?/coerce expr)) clause) 20 | ...)])) 21 | 22 | (define-syntax-rule (form-clause* form-name guard-expr [id question type compute-expr]) 23 | (begin 24 | (define id undefined) 25 | (gui-add! form-name ; container 26 | type ; widget 27 | question ; label 28 | (lambda () guard-expr) ;guard 29 | (lambda (v) (set! id v)) ; set value 30 | compute-expr))) 31 | 32 | ; ---------------------------------------- 33 | 34 | (form Box1HouseOwning 35 | [hasSoldHouse "Did you sell a house in 2010?" boolean-widget] 36 | (when hasSoldHouse 37 | [sellingPrice "Price the house was sold for:" money-widget] 38 | [privateDebt "Private debts for the sold house:" money-widget] 39 | [valueResidue "Value residue:" money-widget (-/coerce sellingPrice privateDebt)])) 40 | -------------------------------------------------------------------------------- /ql/solutions/form-4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "gui.rkt" 3 | "ops.rkt") 4 | (provide form 5 | (rename-out [boolean-widget boolean] 6 | [money-widget money] 7 | 8 | [-/coerce -] 9 | [>/coerce >] 10 | [/coerce >] 10 | [/coerce >] 11 | [/coerce >] 12 | [/coerce >] 13 | [/typed >] 13 | [/typed >/coerce money money boolean) 82 | (define-binary-typed =/typed =/coerce money money boolean) 83 | (define-binary-typed and/typed and/coerce boolean boolean boolean) 84 | (define-binary-typed or/typed or/coerce boolean boolean boolean) 85 | -------------------------------------------------------------------------------- /ql/solutions/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module reader racket/base 4 | (require parser-tools/lex 5 | "reader.rkt" 6 | "color-lexer.rkt") 7 | 8 | (provide read-syntax 9 | read 10 | get-info) 11 | 12 | ;; To get info about the language's environment support: 13 | (define (get-info in mod line col pos) 14 | (lambda (key default) 15 | (case key 16 | [(color-lexer) color-lexer] 17 | [else default])))) 18 | --------------------------------------------------------------------------------