├── .github └── workflows │ └── push.yml ├── LICENSE ├── README.md ├── info.rkt ├── lang └── reader.rkt ├── main.rkt ├── test-object-notation.rkt └── test-ref-expressions.rkt /.github/workflows/push.yml: -------------------------------------------------------------------------------- 1 | on: 2 | - push 3 | - pull_request 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - name: Checkout 10 | uses: actions/checkout@master 11 | - name: Install Racket 12 | uses: Bogdanp/setup-racket@v1.8.1 13 | with: 14 | architecture: 'x64' 15 | distribution: 'full' 16 | variant: 'CS' 17 | version: '8.5' 18 | dest: '"${HOME}/racketdist"' 19 | local_catalogs: $GITHUB_WORKSPACE 20 | sudo: never 21 | - name: Register local packages 22 | run: | 23 | raco pkg install --name super 24 | - name: Setup Collections 25 | run: raco setup --check-pkg-deps super 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Jens Axel Søgaard 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # super 2 | 3 | ## Introduction 4 | 5 | The `super` language is a meta-language that adds features 6 | to an existing racket language. 7 | 8 | Use it as: 9 | 10 | #lang super 11 | 12 | where is the name of an language like racket, racket or similar. 13 | 14 | 15 | 16 | ## Field and Method Access, Method Calls 17 | 18 | In a super language identifiers with dots can be used for field access 19 | and for method calls. 20 | 21 | 1. o.f access field f of object o 22 | 23 | 2. o.f1.f2 access field f2 of object o.f1 24 | 25 | 3. (o .m a ...) invoke method m on object o wth arguments a... 26 | 27 | 4. (o .m1 a1 ... .m2 a2 ...) same as ((o .m1 a1 ...) .m2 a2 ...) 28 | 29 | 5. (o.m a ...) invoke method m on object o wth arguments a... 30 | 31 | 6. (o.m a ... .m1 a1 ...) invoke method m1 on resultof object (o.m a ...) with arguments a2 ... 32 | 33 | See `test-object-notation.rkt` for an example. 34 | 35 | ## Indexing with square brackets 36 | 37 | In a super language the reader reads an expressions of the form 38 | 39 | id[expr ...] (no space between the identifier and the bracket) 40 | 41 | as 42 | 43 | (#%ref id expr ...). 44 | 45 | A default binding for `#%ref` is provide that allows indexing for 46 | vectors, lists, strings and bytes. 47 | 48 | The default bindings is defined like this: 49 | 50 | (define-syntax (#%ref stx) 51 | (syntax-parse stx 52 | [(#%ref x:id index:expr) 53 | (syntax/loc stx 54 | (let ([i index]) 55 | (cond 56 | [(vector? x) (vector-ref x i)] 57 | [(list? x) (list-ref x i)] 58 | [(string? x) (string-ref x i)] 59 | [(bytes? x) (bytes-ref x i)] 60 | [else 61 | (error '#%ref (~a "expected a vector, list, string or byte string, got: " x))])))])) 62 | 63 | See `test-ref-expressions.rkt` for an example. 64 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "super") 4 | (define version "1.0") 5 | (define test-omit-paths '("test-object-notation.rkt" "test-ref-expressions.rkt" "test-base.rkt")) 6 | 7 | (define deps '("base")) 8 | 9 | 10 | -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; The function `make-meta-reader` is used to implement meta langauges 3 | ;; that adjusts an existing language. 4 | ;; We want 5 | ;; #lang super 6 | ;; to behave mostly as , but we want to: 7 | ;; - use #%app and #%top from super/main 8 | ;; - adjust forms of the type: 9 | ;; id[expr] 10 | ;; (an expression consisting of an identifer followed directly 11 | ;; be an expression in square brackets) 12 | ;; The expression 13 | ;; id[expr] 14 | ;; is rewritten to 15 | ; (#%ref id expr ...). 16 | 17 | (require (only-in syntax/module-reader make-meta-reader)) 18 | 19 | ;; The procedure `make-meta-reader` produces adjusted versions 20 | ;; of `read`, `read-syntax` and `read-get-info`. 21 | 22 | (provide (rename-out [super-read read] 23 | [super-read-syntax read-syntax] 24 | [super-get-info get-info])) 25 | 26 | 27 | ; After standard reading, we will rewrite 28 | ; id[expr ...] 29 | ; to 30 | ; (#%ref id expr ...). 31 | 32 | ; We will use this to index to vectors, strings and hash tables. 33 | 34 | ; Since `adjust` is called after reading, we are essentially working with 35 | ; three passes. 36 | ; - read-syntax 37 | ; - adjust 38 | ; - expand 39 | 40 | ; Let's define our `adjust` pass. 41 | 42 | (require racket/runtime-path racket/syntax 43 | (except-in syntax/parse char)) 44 | 45 | (define (read-string str #:source-name [source-name #f]) 46 | (define in (open-input-string str)) 47 | ; (port-count-lines! in) 48 | (read-syntax source-name in)) 49 | 50 | (define (adjust stx) 51 | (syntax-parse stx 52 | [(a . d) (adjust-dotted-list stx)] 53 | [_ stx])) 54 | 55 | (define (wrap-reader reader) 56 | (define (adjusted-reader . args) 57 | (inject-new-app-and-top (adjust (apply reader args)))) 58 | adjusted-reader) 59 | 60 | (define (inject-new-app-and-top stx) 61 | (syntax-parse stx 62 | [(mod name lang (mod-begin . more) . even-more) 63 | (with-syntax ([req (datum->syntax #f '(require (only-in super/main #%app #%top #%ref)) stx)]) 64 | (syntax/loc stx 65 | (mod name lang 66 | (mod-begin req . more) 67 | . even-more)))])) 68 | 69 | (define (adjust-dotted-list stx) 70 | (syntax-parse stx 71 | [(id:id (~and [e:expr ...] brackets) . more) 72 | (cond 73 | [(and (eqv? (syntax-property #'brackets 'paren-shape) #\[) 74 | (= (+ (syntax-position #'id) (syntax-span #'id)) 75 | (syntax-position #'brackets))) 76 | (let ([adjusted-more (adjust #'more)] 77 | [arguments (syntax->list #'(id e ...))]) 78 | (datum->syntax #f 79 | `((#%ref ,@arguments) . ,adjusted-more) 80 | stx))] 81 | [else 82 | (with-syntax ([(_ . rest) stx]) 83 | (let ([adjusted-rest (adjust-dotted-list #'rest)]) 84 | (datum->syntax #f 85 | `(,#'id . ,adjusted-rest) 86 | stx)))])] 87 | [(a . more) 88 | (let ([adjusted-a (adjust #'a)] 89 | [adjusted-more (adjust #'more)]) 90 | (datum->syntax #f 91 | `(,adjusted-a . ,adjusted-more) 92 | stx))] 93 | [_ 94 | (raise-syntax-error 'adjust-dotted-list "expected a dotted list" stx)])) 95 | 96 | ;; Now are ready to wrap `read`, `read-syntax` and `read-get-info` from . 97 | 98 | (define-values (super-read super-read-syntax super-get-info) 99 | (make-meta-reader 100 | ; self-sym 101 | 'super 102 | ; path-desc-str 103 | "language path" 104 | ; module-path-parser 105 | (lambda (bstr) 106 | (let* ([str (bytes->string/latin-1 bstr)] 107 | [sym (string->symbol str)]) 108 | (and (module-path? sym) 109 | (vector 110 | ;; try submod first: 111 | `(submod ,sym reader) 112 | ;; fall back to /lang/reader: 113 | (string->symbol (string-append str "/lang/reader")))))) 114 | ; convert-read 115 | wrap-reader 116 | ; convert-read-syntax 117 | wrap-reader 118 | ; convert-get-info 119 | (lambda (proc) 120 | (lambda (key defval) 121 | (define (fallback) (if proc (proc key defval) defval)) 122 | (case key 123 | [(color-lexer) 124 | (or (fallback) 125 | (dynamic-require 'syntax-color/racket-lexer 'racket-lexer))] 126 | [else (fallback)]))))) 127 | 128 | 129 | ; > (displayln (adjust (read-string "(foo[bar])"))) 130 | ; # 131 | 132 | ; > (displayln (adjust (read-string "(foo [bar])"))) 133 | ; # 134 | 135 | ; > (displayln (adjust (read-string "(foo v[1] bar)"))) 136 | ; # 137 | 138 | 139 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (except-out (all-from-out racket) #%top #%app) 3 | #%ref) 4 | 5 | ;;; 6 | ;;; Field and Method Access, Method Calls 7 | ;;; 8 | 9 | ;; Goal 10 | ;; ---- 11 | 12 | ;; 1. o.f access field f of object o 13 | ;; 2. o.f1.f2 access field f2 of object o.f1 14 | 15 | ;; 3. (o .m a ...) invoke method m on object o wth arguments a... 16 | ;; 4. (o .m1 a1 ... .m2 a2 ...) same as ((o .m1 a1 ...) .m2 a2 ...) 17 | ;; 5. (o.m a ...) invoke method m on object o wth arguments a... 18 | ;; 6. (o.m a ... .m1 a1 ...) invoke method m1 on resultof object (o.m a ...) with arguments a2 ... 19 | 20 | 21 | ;; Ad 1. and 3. 22 | ;; - use #%top to rewrite 23 | ;; o.f into (get-field f o) 24 | ;; o.f1.f2 into (get-field f2 (get-field f1 o)) 25 | 26 | ;; Ad 2. and 3. 27 | ;; - use #%app to rewrite applications with method calls 28 | 29 | 30 | ;; Implementation 31 | ;; -------------- 32 | 33 | ;; We are going to define our own versions of #%app and #%top named .app and .top. 34 | ;; We will export them under the names #%app and #%top. 35 | 36 | (provide (rename-out [.app #%app])) 37 | (provide (rename-out [.top #%top])) 38 | 39 | 40 | ;; Utilities for working with identifiers 41 | 42 | (require (for-syntax racket/base racket/syntax syntax/parse syntax/stx 43 | racket/string racket/list)) 44 | (require racket/match racket/format) 45 | 46 | (begin-for-syntax 47 | (define (identifier->string id) 48 | (cond 49 | [(string? id) id] 50 | [(symbol? id) (symbol->string id)] 51 | [else (symbol->string (syntax-e id))])) 52 | 53 | (define (string->identifier ctx src str) 54 | (when (syntax? str) (set! str (syntax-e str))) 55 | (datum->syntax ctx (string->symbol str) src)) 56 | 57 | (define (identifier-append ctx srcloc . ids) 58 | (define (-> x) (datum->syntax ctx x srcloc)) 59 | (-> (string->symbol (string-append* (map identifier->string ids))))) 60 | 61 | (define (identifier-append* ctx srcloc ids) 62 | (apply identifier-append ctx srcloc ids)) 63 | 64 | (define (identifier-split id sep) 65 | ; Like string-split, but for identifiers. 66 | ; Returns a syntax object with a list of strings. 67 | (define str (identifier->string id)) 68 | (define parts (string-split str sep)) 69 | (define ctx id) 70 | (define srcloc id) 71 | (define (-> x) (datum->syntax ctx x srcloc)) 72 | (-> (map -> parts))) 73 | 74 | (define (identifier-contains? id contained-str) 75 | (string-contains? (identifier->string id) 76 | contained-str)) 77 | 78 | (define (identifier-begins-with? id start-ch) 79 | (unless (char? start-ch) 80 | (error 'identifier-begins-with? "expected a character as start-ch")) 81 | (define str (identifier->string id)) 82 | (and (not (zero? (string-length str))) 83 | (eqv? (string-ref str 0) start-ch))) 84 | 85 | (define (dot-identifier? id) 86 | (eqv? (string-ref (identifier->string id) 0) #\.)) 87 | 88 | (define (method-identifier? id) 89 | (and (identifier-begins-with? id #\.) 90 | (not (identifier-contains? (identifier-drop-start id) ".")))) 91 | 92 | (define (identifier-drop-start id) 93 | (define str (identifier->string id)) 94 | (define sym (string->symbol (substring str 1 (string-length str)))) 95 | (datum->syntax id sym id id)) 96 | 97 | 98 | (define (identifiers->dotted-name id ids) 99 | (when (syntax? ids) (set! ids (syntax->list ids))) 100 | (identifier-append* id id (add-between ids #'|.|))) 101 | 102 | (define (dotted-identifier->identifiers id) 103 | (define (-> x) (datum->syntax id x id)) 104 | (define strs (string-split (identifier->string #'id) ".")) 105 | (define syms (map string->symbol strs)) 106 | (map -> syms))) 107 | 108 | ;; Syntax classes makes parsing our new forms easier. 109 | 110 | (begin-for-syntax 111 | (define-syntax-class name ; an identifier without dots 112 | (pattern name:id 113 | #:when (not (identifier-contains? #'name ".")))) 114 | 115 | (define-syntax-class method ; an identifier that begins with a dot 116 | (pattern dot-name:id 117 | #:when (identifier-begins-with? #'dot-name #\.) 118 | #:attr name (identifier-drop-start #'dot-name))) 119 | 120 | (define-syntax-class non-method 121 | (pattern (~not expr:method))) 122 | 123 | (define-syntax-class non-method-id ; an identifier that does not begin with a dot 124 | (pattern name:id 125 | #:when (not (identifier-begins-with? #'name #\.)))) 126 | 127 | (define-syntax-class dotted-name 128 | (pattern dotted-name:id 129 | #:when (identifier-contains? #'dotted-name ".") 130 | #:attr names (identifier-split #'dotted-name ".")))) 131 | 132 | ;;; 133 | ;;; #%top 134 | ;;; 135 | 136 | ;; Ad 1. and 3. 137 | ;; - use #%top to rewrite 138 | ;; o.f into (get-field f o) 139 | ;; o.f1.f2 into (get-field f2 (get-field f1 o)) 140 | 141 | (define-syntax (.top stx) 142 | ; like #%top, but dotted identifiers are field or method access 143 | (syntax-parse stx 144 | ; Names (identifiers without dots) resolve as usual. 145 | [(_.top . id:name) 146 | #'(#%top . id)] 147 | 148 | [(_.top . id:dotted-name) 149 | (cond 150 | ; If the name beings with a . it is not a field or method access. 151 | [(identifier-begins-with? #'id #\.) 152 | #'(#%top . id)] 153 | 154 | [(identifier-contains? #'id ".") 155 | ; Double dots in an identifier is not allowed 156 | (when (identifier-contains? #'id "..") 157 | (raise-syntax-error '.top "two consecutive dots not allowed" #'id)) 158 | 159 | (define (-> x) (string->identifier stx #'id x)) 160 | (syntax-parse (stx-map -> #'id.names) 161 | ; fast path (could be omitted) 162 | [(o f) (syntax/loc #'id 163 | (get-field f o))] 164 | [(o . fs) (define (loop o fs) 165 | (syntax-parse fs 166 | [() o] 167 | [(f . fs) (loop (with-syntax ([o o]) 168 | (syntax/loc #'id 169 | (get-field f o))) 170 | #'fs)])) 171 | (loop #'o #'fs)])])] 172 | [(_.top . id) 173 | ; better safe than sorry 174 | #'(#%top . id)])) 175 | 176 | ;;; 177 | ;;; #%app 178 | ;;; 179 | 180 | ;; 3. (o .m a ...) invoke method m on object o wth arguments a... 181 | ;; 4. (o .m1 a1 ... .m2 a2 ...) same as ((o .m1 a1 ...) .m2 a2 ...) 182 | ;; 5. (o.m a ...) invoke method m on object o with arguments a... 183 | ;; 6. (o.m a ... .m1 a1 ...) invoke method m1 on resultof object (o.m a ...) with arguments a2 ... 184 | 185 | (define-syntax (.app stx) 186 | (syntax-parse stx 187 | ; 5. (o.m a ...) 188 | [(_.app id:dotted-name arg:non-method ...) 189 | (define (-> x) (string->identifier #'id #'id x)) 190 | (with-syntax ([(o f ... m) (stx-map -> #'id.names)]) 191 | (with-syntax ([o.fs (identifiers->dotted-name #'id #'(o f ...))]) 192 | (syntax/loc stx 193 | (let ([obj o.fs] 194 | [args (list arg ...)]) ; don't duplicate arg ... 195 | (cond 196 | [(and (object? obj) (method-in-interface? 'm (object-interface obj))) 197 | (send/apply o m args)] 198 | [(and (object? obj) (field-bound? m obj)) 199 | (apply (get-field m obj) args)] 200 | [(object? obj) 201 | (raise-syntax-error 202 | '.app (~a "the object does not not have a field or method named: " 'm) #'id)] 203 | [else 204 | (raise-syntax-error 205 | '.app (~a "expected an object, got: " obj) #'id)])))))] 206 | ; 6. (o.m a ... .m1 a1 ...) 207 | [(_.app id:dotted-name a:non-method ... m1:method . more) 208 | (syntax/loc stx 209 | (let ([obj (.app id a ...)]) 210 | (send obj m1.name . more)))] 211 | ; (e .m a ...) 212 | [(_.app e:expr method:method arg:non-method ...) 213 | (syntax/loc stx 214 | (let ([o e]) 215 | (send o method.name arg ...)))] 216 | ; (e .m a ... .m2 a2 ...) 217 | [(_.app e:expr method:method arg:non-method ... method2:method . more) 218 | (syntax/loc stx 219 | (let ((o e)) 220 | (let ([o1 (send o method.name arg ...)]) 221 | (.app o1 method2 . more))))] 222 | ; (e a ...) 223 | [(_.app e:expr arg:non-method ...) 224 | (syntax/loc stx 225 | (e arg ...))])) 226 | 227 | ;;; 228 | ;;; (#%ref x index) 229 | ;;; 230 | 231 | 232 | (define (object-ref x i) 233 | (with-handlers ([exn:fail:object? rewrite-object-ref-exception]) 234 | (send x subscript-get i))) 235 | 236 | (define (rewrite-object-ref-exception exn) 237 | ; The original message currently looks like: 238 | ; "send: no such method\n method name: subscript-get\n class name: Array" 239 | (define msg (exn-message exn)) 240 | (define marks (exn-continuation-marks exn)) 241 | (define rewrite? (and (string-prefix? msg "send") (string-contains? msg "subscript-get"))) 242 | (define new-msg (or (and rewrite? "#%ref: object is not subscriptable\n class name: Array") msg)) 243 | (raise (exn:fail:object new-msg marks))) 244 | 245 | (define (default-ref value index) 246 | (define x value) 247 | (define i index) 248 | (cond 249 | [(list? x) (list-ref x i)] 250 | [(bytes? x) (bytes-ref x i)] 251 | [(object? x) (object-ref x i)] 252 | [else 253 | (error '#%ref (~a "expected a vector, list, string or byte string, got: " x))])) 254 | 255 | (define-syntax (#%ref stx) 256 | (syntax-parse stx 257 | [(#%ref x:id index:expr) 258 | (syntax/loc stx 259 | (let ([i index]) 260 | (cond 261 | [(vector? x) (vector-ref x i)] 262 | [(string? x) (string-ref x i)] 263 | [else (default-ref x i)])))])) 264 | -------------------------------------------------------------------------------- /test-object-notation.rkt: -------------------------------------------------------------------------------- 1 | #lang super racket 2 | 3 | (define point% 4 | (class* object% (printable<%>) 5 | (super-new) 6 | (init-field [x 0] [y 0]) 7 | 8 | (define/public (custom-print port qq-depth) (do-print this print port)) 9 | (define/public (custom-display port) (do-print this display port)) 10 | (define/public (custom-write port) (do-print this write port)) 11 | (define (do-print object out port) 12 | (display (~a "(object:point% x=" x " y=" y ")") port)) 13 | 14 | (define/public (move-x dx) 15 | (new this% [x (+ x dx)] [y y])) 16 | (define/public (move-y dy) 17 | (new this% [y (+ y dy)] [x x])) 18 | (define/public (get-x) 19 | x))) 20 | 21 | (define circle% 22 | (class object% 23 | (super-new) 24 | (init-field [center (new point%)] [radius 1]))) 25 | 26 | ;; 1. o.f field access 27 | (define p (new point% [x 11] [y 22])) 28 | p 29 | p.x 30 | 31 | ;; 2. o.f1.f2 repeated field access 32 | 33 | (define c (new circle% [center p] [radius 33])) 34 | c.radius 35 | c.center.x 36 | c.center.y 37 | 38 | 39 | ;; 3. (o .m a ...) invoke method m on object o wth arguments a... 40 | 41 | (define p2 (p .move-x 1)) 42 | p2.x 43 | 44 | ;; 4. (o .m1 a1 ... .m2 a2 ...) same as ((o .m1 a1 ...) .m2 a2 ...) 45 | (p .move-x 1 .move-y 2 .get-x) 46 | 47 | ;; 5. (o.m a ...) invoke method m on object o wth arguments a... 48 | 49 | (p.move-x 20) 50 | (p.move-x 20 .move-y 4) 51 | 52 | ; same as 53 | (p .move-x 20 .move-y 4) 54 | 55 | 56 | -------------------------------------------------------------------------------- /test-ref-expressions.rkt: -------------------------------------------------------------------------------- 1 | #lang super racket 2 | 3 | (define v (vector 0 11 22 33 44)) 4 | (define l (vector 0 111 222 333 444)) 5 | (define s "foo") 6 | (define b #"bar") 7 | 8 | v[1] 9 | l[1] 10 | s[1] 11 | b[1] 12 | 13 | (define Array (class object% 14 | (init-field elements) 15 | (super-new) 16 | #;(define/public (subscript-get i) 17 | (vector-ref elements i)))) 18 | 19 | (define an-array (new Array [elements #(a b c d e)])) 20 | 21 | an-array[2] 22 | --------------------------------------------------------------------------------