├── .gitignore ├── LICENSE ├── README.md ├── clojure ├── clojure.rkt ├── lang │ ├── language-info.rkt │ ├── reader-no-wrap.rkt │ ├── reader.rkt │ └── runtime-config.rkt ├── main.rkt ├── nil.rkt ├── printer.rkt ├── reader.rkt ├── reader │ └── parse-afl.rkt ├── repl.rkt ├── string.rkt └── tests │ └── test.rkt └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | *~ 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Asumu Takikawa 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | \#lang clojure 2 | ============= 3 | 4 | This project is a stub for a Clojure compatibility language in Racket. 5 | 6 | Its primary purpose is to let me practice writing macros and using 7 | Racket's language extensions tools. If you are interested in making this 8 | usable for real purposes, feel free to send me pull requests. 9 | 10 | To install on Racket 5.3.4 and newer: 11 | 12 | * `git clone git://github.com/takikawa/racket-clojure.git` 13 | * `raco pkg install racket-clojure/` 14 | 15 | On older versions of Racket: 16 | 17 | * `git clone git://github.com/takikawa/racket-clojure.git` 18 | * `raco link racket-clojure` 19 | * `raco setup clojure` 20 | 21 | TODO items: 22 | 23 | * Simulate Clojure namespaces using modules/namespaces 24 | * Simulate Clojure macros 25 | * Simulate Clojure protocols 26 | * More compatibility bindings under `clojure/*` 27 | * And a lot more... 28 | 29 | --- 30 | 31 | Copyright (c) 2013 Asumu Takikawa 32 | 33 | Licensed under the MIT license. See LICENSE. 34 | 35 | -------------------------------------------------------------------------------- /clojure/clojure.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Clojure compatibility 4 | 5 | (require (prefix-in rkt: racket/base) 6 | (prefix-in rkt: racket/set) 7 | racket/stxparam 8 | "nil.rkt" 9 | "printer.rkt" 10 | (for-syntax racket/base 11 | racket/list 12 | syntax/parse 13 | syntax/strip-context 14 | )) 15 | 16 | (provide (except-out (all-from-out racket/base) 17 | add1 sub1 if cond #%app #%datum #%top quote) 18 | (rename-out [-#%app #%app] 19 | [-#%datum #%datum] 20 | [-#%top #%top] 21 | [-quote quote] 22 | [sub1 dec] 23 | [add1 inc] 24 | [clojure:cond cond] 25 | [clojure:if if]) 26 | def do let fn defn loop recur 27 | -> ->> 28 | partial comp complement constantly 29 | vector str 30 | hash-map map? zipmap get keys vals assoc dissoc 31 | hash-set set? disj 32 | map nth 33 | true false nil boolean not 34 | = == identical? 35 | pr prn pr-str prn-str 36 | ) 37 | 38 | (define-syntax-parameter recur 39 | (λ (stx) 40 | (raise-syntax-error #f "cannot be used outside fn or loop" stx))) 41 | 42 | ;; basic forms 43 | (define-syntax (def stx) 44 | (syntax-parse stx 45 | [(_ name:id init) 46 | #'(define name init)])) 47 | 48 | (define-syntax-rule (do expr ...) 49 | (begin expr ...)) 50 | 51 | (define true #t) 52 | (define false #f) 53 | 54 | ;; used for let and loop 55 | (begin-for-syntax 56 | (define-splicing-syntax-class binding-pair 57 | #:description "binding pair" 58 | (pattern (~seq name:id val:expr)))) 59 | 60 | (define-syntax (let stx) 61 | (syntax-parse stx 62 | [(_ #[p:binding-pair ...] 63 | body:expr ...) 64 | #'(let* ([p.name p.val] ...) 65 | body ...)])) 66 | 67 | (define-syntax (loop stx) 68 | (syntax-parse stx 69 | [(_ #[p:binding-pair ...] 70 | body:expr ...) 71 | #:with name #'x 72 | #'(letrec ([name (λ (p.name ...) 73 | (syntax-parameterize ([recur (make-rename-transformer #'name)]) 74 | body ...))]) 75 | (let* ([p.name p.val] ...) 76 | (name p.name ...)))])) 77 | 78 | (define-syntax (fn stx) 79 | (syntax-parse stx 80 | [(_ (~optional name:id #:defaults ([name #'x])) 81 | #[param:id ...] body ...) 82 | #'(letrec ([name (λ (param ...) 83 | (syntax-parameterize ([recur (make-rename-transformer #'name)]) 84 | body ...))]) 85 | name)] 86 | [(_ (~optional name:id #:defaults ([name #'x])) 87 | (#[param:id ...] body ...) ...+) 88 | #'(letrec ([name (syntax-parameterize ([recur (make-rename-transformer #'name)]) 89 | (case-lambda 90 | ([param ...] body ...) ...))]) 91 | name)])) 92 | 93 | (define-syntax (defn stx) 94 | (syntax-parse stx 95 | [(_ name:id expr ...) 96 | #'(define name (fn expr ...))])) 97 | 98 | ;; thrush operators 99 | (define-syntax (-> stx) 100 | (syntax-parse stx 101 | [(_ x) #'x] 102 | [(_ x (e e_1 ...)) 103 | #'(e x e_1 ...)] 104 | [(_ x e) 105 | #'(-> x (e))] 106 | [(_ x form form_1 ...) 107 | #'(-> (-> x form) form_1 ...)])) 108 | 109 | (define-syntax (->> stx) 110 | (syntax-parse stx 111 | [(_ x) #'x] 112 | [(_ x (e e_1 ...)) 113 | #'(e e_1 ... x)] 114 | [(_ x e) 115 | #'(->> x (e))] 116 | [(_ x form form_1 ...) 117 | #'(->> (->> x form) form_1 ...)])) 118 | 119 | (define (not v) 120 | (or (eq? v #f) (eq? v nil))) 121 | 122 | (define (boolean v) 123 | (rkt:not (not v))) 124 | 125 | (define-syntax (clojure:if stx) 126 | (syntax-parse stx 127 | [(_ test then) 128 | #'(if (boolean test) then nil)] 129 | [(_ test then else) 130 | #'(if (boolean test) then else)])) 131 | 132 | ;; modify lexical syntax via macros 133 | (begin-for-syntax 134 | (define-splicing-syntax-class key-value-pair 135 | (pattern (~seq k:key e:expr) 136 | #:attr pair #'(k.sym e))) 137 | 138 | (define-syntax-class key 139 | (pattern e:expr 140 | #:when (clojure-kwd? #'e) 141 | #:attr sym #'(quote e))) 142 | 143 | (define (clojure-kwd? e) 144 | (define exp (syntax-e e)) 145 | (and (symbol? exp) 146 | (regexp-match #rx":.*" (symbol->string exp))))) 147 | 148 | (define-syntax (-quote stx) 149 | (syntax-parse stx 150 | ;; Clojure's quote allows multiple arguments 151 | [(_ e e_1 ...) #'(quote e)])) 152 | 153 | (define-syntax -#%datum 154 | (lambda (stx) 155 | (syntax-parse stx 156 | [(-#%datum . #[e ...]) 157 | (syntax/loc stx (vector e ...))] 158 | [(-#%datum . hsh) 159 | #:when (syntax-property #'hsh 'clojure-hash-map) 160 | #:with (e ...) (replace-context #'hsh (syntax-property #'hsh 'clojure-hash-map)) 161 | (syntax/loc stx (hash-map e ...))] 162 | [(-#%datum . st) 163 | #:when (syntax-property #'st 'clojure-set) 164 | #:with (e:expr ...) (replace-context #'st (syntax-property #'st 'clojure-set)) 165 | (syntax/loc stx (hash-set e ...))] 166 | [(-#%datum . e) 167 | (syntax/loc stx (#%datum . e))]))) 168 | 169 | (define-syntax (-#%app stx) 170 | (syntax-parse stx 171 | [(_ proc:expr arg:expr ...) 172 | #'(#%app proc arg ...)])) 173 | 174 | (define-syntax -#%top 175 | (lambda (stx) 176 | (syntax-parse stx 177 | [(-#%top . id) 178 | #:when (syntax-property #'id 'clojure-keyword) 179 | (syntax/loc stx (quote id))] 180 | [(-#%top . id) 181 | (syntax/loc stx (#%top . id))]))) 182 | 183 | (define-syntax clojure:cond 184 | (lambda (stx) 185 | (syntax-case stx (:else) 186 | [(_) 187 | #'nil] 188 | [(_ :else else-expr) 189 | #'else-expr] 190 | [(_ e1 e2 e3 ...) 191 | (if (even? (length (syntax->list #'(e1 e2 e3 ...)))) 192 | #'(if (boolean e1) e2 193 | (clojure:cond e3 ...)) 194 | (raise-syntax-error #f "cond requires an even number of forms" stx))]))) 195 | 196 | ;; lists - examine 197 | (define nth 198 | (case-lambda 199 | [(coll position) 200 | (sequence-ref coll position)] 201 | [(coll position error-msg) 202 | (if (or (= 0 (sequence-length coll)) 203 | (> position (sequence-length coll))) 204 | error-msg 205 | (sequence-ref coll position))])) 206 | 207 | ;; useful functions 208 | (require racket/function) 209 | 210 | (define partial curry) 211 | (define comp compose) 212 | (define complement negate) 213 | (define constantly const) 214 | 215 | ;; sequences 216 | (require racket/sequence 217 | racket/stream) 218 | 219 | (define (first s) stream-first) 220 | (define (rest s) stream-rest) 221 | (define (cons fst rst) (stream-cons fst rst)) 222 | (define map sequence-map) 223 | 224 | (define (vector . args) 225 | (apply vector-immutable args)) 226 | 227 | (define (str . args) 228 | (string->immutable-string 229 | (apply string-append (rkt:map toString args)))) 230 | 231 | ;; private: can return a mutable string because str will still produce an immutable one 232 | (define (toString v) 233 | (cond [(rkt:string? v) v] 234 | [(nil? v) ""] 235 | [(char? v) (rkt:string v)] 236 | [else (pr-str v)])) 237 | 238 | (define (hash-map . args) 239 | (apply hash args)) 240 | 241 | (define (map? v) 242 | (and (hash? v) (immutable? v))) 243 | 244 | (define (hash-set . args) 245 | (apply rkt:set args)) 246 | 247 | (define (set? v) 248 | (rkt:set? v)) 249 | 250 | (define (zipmap keys vals) 251 | (for/hash ([k keys] [v vals]) 252 | (values k v))) 253 | 254 | (define (get map key [not-found nil]) 255 | (hash-ref map key (λ () not-found))) 256 | 257 | (define (keys map) 258 | (hash-keys map)) 259 | 260 | (define (vals map) 261 | (hash-values map)) 262 | 263 | (define (assoc map . k/vs) 264 | (apply hash-set* map k/vs)) 265 | 266 | (define (dissoc map . ks) 267 | (for/fold ([map map]) ([k (in-list ks)]) 268 | (hash-remove map k))) 269 | 270 | (define (disj set . ks) 271 | (for/fold ([set set]) ([k (in-list ks)]) 272 | (rkt:set-remove set k))) 273 | 274 | (define (= a . bs) 275 | (for/and ([b (in-list bs)]) 276 | (equal? a b))) 277 | 278 | (define (== a . bs) 279 | (if (number? a) 280 | (and (andmap number? bs) 281 | (apply rkt:= a bs)) 282 | (for/and ([b (in-list bs)]) 283 | (equal?/recur a b ==)))) 284 | 285 | (define (identical? a b) 286 | (eq? a b)) 287 | 288 | -------------------------------------------------------------------------------- /clojure/lang/language-info.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide get-language-info) 4 | 5 | (define (get-language-info data) 6 | (lambda (key default) 7 | (case key 8 | [(configure-runtime) 9 | '(#[clojure/lang/runtime-config configure #f])] 10 | [else default]))) 11 | 12 | -------------------------------------------------------------------------------- /clojure/lang/reader-no-wrap.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | clojure/clojure 3 | #:language-info '#[clojure/lang/language-info get-language-info #f] 4 | -------------------------------------------------------------------------------- /clojure/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide read read-syntax get-info) 4 | 5 | (require clojure/reader 6 | (prefix-in - "reader-no-wrap.rkt")) 7 | 8 | (define read (wrap-reader -read)) 9 | (define read-syntax (wrap-reader -read-syntax)) 10 | (define get-info -get-info) 11 | 12 | -------------------------------------------------------------------------------- /clojure/lang/runtime-config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide configure) 4 | 5 | (require (only-in clojure/reader make-clojure-readtable current-syntax-introducer make-intro) 6 | (only-in clojure/printer pr)) 7 | 8 | (define (configure data) 9 | (current-syntax-introducer (make-intro)) 10 | (current-readtable (make-clojure-readtable)) 11 | (current-print (make-print-proc (current-print))) 12 | ) 13 | 14 | (struct clojure-pr-thing (v) 15 | #:property prop:custom-write 16 | (λ (this out mode) 17 | (pr (clojure-pr-thing-v this) #:out out))) 18 | 19 | (define ((make-print-proc orig-print-proc) v) 20 | (cond [(void? v) v] 21 | [else (orig-print-proc (clojure-pr-thing v))])) 22 | 23 | -------------------------------------------------------------------------------- /clojure/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require clojure/clojure) 4 | (provide (all-from-out clojure/clojure)) 5 | 6 | -------------------------------------------------------------------------------- /clojure/nil.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide nil nil?) 4 | 5 | (define nil (void)) 6 | 7 | (define (nil? v) (void? v)) 8 | 9 | -------------------------------------------------------------------------------- /clojure/printer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide pr prn pr-str prn-str) 4 | 5 | (require racket/match 6 | racket/list 7 | racket/set 8 | racket/format 9 | "nil.rkt" 10 | ) 11 | 12 | ;; pr : Any ... [#:out Output-Port] -> Nil 13 | ;; analogous to write in racket 14 | (define (pr #:out [out (current-output-port)] . args) 15 | (pr1-list/open-close args "" "" out pr1)) 16 | 17 | ;; pr1 : Any #:out Output-Port -> Nil 18 | (define (pr1 v #:out out) 19 | (cond 20 | [(list? v) 21 | (pr1-list/open-close v "(" ")" out pr1)] 22 | [(vector? v) 23 | (pr1-list/open-close (vector->list v) "[" "]" out pr1)] 24 | [(hash? v) 25 | (pr1-list/open-close (append* (hash-map v list)) "{" "}" out pr1)] 26 | [(set? v) 27 | (pr1-list/open-close (set->list v) "#{" "}" out pr1)] 28 | [(nil? v) 29 | (write-string "nil" out) 30 | nil] 31 | [(char? v) 32 | (write-string (substring (~s v) 1) out) 33 | nil] 34 | [(or (symbol? v) (number? v) (string? v)) 35 | (write v out) 36 | nil] 37 | [else 38 | (write-string "#" out) 41 | nil])) 42 | 43 | (define (prn #:out [out (current-output-port)] . args) 44 | (apply pr #:out out args) 45 | (newline out) 46 | nil) 47 | 48 | (define (pr-str . args) 49 | (define out (open-output-string)) 50 | (apply pr #:out out args) 51 | (string->immutable-string (get-output-string out))) 52 | 53 | (define (prn-str . args) 54 | (define out (open-output-string)) 55 | (apply prn #:out out args) 56 | (string->immutable-string (get-output-string out))) 57 | 58 | ;; pr1-list/open-close : 59 | ;; (Listof Any) String String Output-Port (Any #:out Output-Port -> Nil) -> Nil 60 | (define (pr1-list/open-close lst open close out rec-pr) 61 | (match lst 62 | ['() 63 | (write-string open out) 64 | (write-string close out) 65 | nil] 66 | [(cons fst rst) 67 | (write-string open out) 68 | (rec-pr fst #:out out) 69 | (for ([x (in-list rst)]) 70 | (write-char #\space out) 71 | (rec-pr x #:out out)) 72 | (write-string close out) 73 | nil])) 74 | 75 | -------------------------------------------------------------------------------- /clojure/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide wrap-reader make-clojure-readtable current-syntax-introducer make-intro) 4 | 5 | (require racket/port 6 | racket/set 7 | syntax/readerr 8 | version/utils 9 | "reader/parse-afl.rkt" 10 | ) 11 | 12 | (define (make-clojure-readtable [rt (current-readtable)]) 13 | (make-readtable rt 14 | #\~ #\, #f 15 | #\, #\space #f 16 | #\_ 'dispatch-macro s-exp-comment-proc 17 | #\[ 'terminating-macro vec-proc 18 | #\{ 'terminating-macro hash-proc 19 | #\{ 'dispatch-macro set-proc 20 | #\\ 'non-terminating-macro char-proc 21 | #\: 'non-terminating-macro kw-proc 22 | #\( 'dispatch-macro afl-proc 23 | )) 24 | 25 | (define (s-exp-comment-proc ch in src ln col pos) 26 | (make-special-comment (read-syntax/recursive src in))) 27 | 28 | (define (vec-proc ch in src ln col pos) 29 | (define lst-stx 30 | (parameterize ([read-accept-dot #f]) 31 | (read-syntax/recursive src in ch (make-readtable (current-readtable) ch #\[ #f)))) 32 | (define lst (syntax->list lst-stx)) 33 | (datum->syntax lst-stx (list->immutable-vector lst) lst-stx lst-stx)) 34 | 35 | (define (list->immutable-vector lst) 36 | (apply vector-immutable lst)) 37 | 38 | (define (hash-proc ch in src ln col pos) 39 | (define lst-stx 40 | (parameterize ([read-accept-dot #f]) 41 | (read-syntax/recursive src in ch (make-readtable (current-readtable) ch #\{ #f)))) 42 | (define lst (syntax->list lst-stx)) 43 | (unless (even? (length lst)) 44 | (raise-read-error "hash map literal must contain an even number of forms" 45 | src ln col pos (syntax-span lst-stx))) 46 | (datum->syntax lst-stx (for/hash ([(k v) (in-hash (apply hash lst))]) ; need syntax property to 47 | (values (syntax->datum k) v)) ; preserve order of evaluation 48 | lst-stx ; and source locations of keys 49 | (syntax-property lst-stx 'clojure-hash-map lst-stx))) 50 | 51 | (define (set-proc ch in src ln col pos) 52 | (define lst-stx 53 | (parameterize ([read-accept-dot #f]) 54 | (read-syntax/recursive src in ch (make-readtable (current-readtable) ch #\{ #f)))) 55 | (datum->syntax lst-stx (list->set (syntax->datum lst-stx)) 56 | lst-stx 57 | (syntax-property lst-stx 'clojure-set lst-stx))) 58 | 59 | (define (char-proc ch in src ln col pos) 60 | (define in* 61 | (parameterize ([port-count-lines-enabled #t]) 62 | (input-port-append #f (open-input-string "\\") in))) 63 | (set-port-next-location! in* ln col pos) 64 | (read-syntax/recursive src in* #\# #f)) 65 | 66 | (define (kw-proc ch in src ln col pos) 67 | (define id-stx 68 | (read-syntax/recursive src in ch (make-readtable (current-readtable) ch #\: #f))) 69 | (syntax-property id-stx 'clojure-keyword #t)) 70 | 71 | (define (afl-proc ch in src ln col pos) 72 | (define lst-stx 73 | (read-syntax/recursive src in ch)) 74 | (parse-afl lst-stx)) 75 | 76 | (define (wrap-reader rd) 77 | (lambda args 78 | (define intro (make-intro)) 79 | (parameterize ([current-readtable (make-clojure-readtable)] 80 | [current-syntax-introducer intro]) 81 | (define stx (apply rd args)) 82 | (if (and (syntax? stx) (version<=? "6.2.900.4" (version))) 83 | (intro stx) 84 | stx)))) 85 | 86 | -------------------------------------------------------------------------------- /clojure/reader/parse-afl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide parse-afl current-syntax-introducer make-intro) 4 | 5 | (require racket/match 6 | racket/list 7 | syntax/srcloc 8 | syntax/parse/define 9 | (for-syntax racket/base 10 | racket/list 11 | )) 12 | (module+ test 13 | (require rackunit)) 14 | 15 | (define-simple-macro (require-a-lot req-spec ...) 16 | #:with (phase ...) (range -10 11) 17 | (require (for-meta phase req-spec ...) ...)) 18 | 19 | (require-a-lot (only-in racket/base lambda define-syntax #%app make-rename-transformer syntax)) 20 | 21 | (define current-syntax-introducer (make-parameter (λ (x) x))) 22 | 23 | (define make-intro 24 | (cond [(procedure-arity-includes? make-syntax-introducer 1) 25 | (λ () (make-syntax-introducer #t))] 26 | [else 27 | (λ () (make-syntax-introducer))])) 28 | 29 | (define (parse-afl stx) 30 | (define intro (current-syntax-introducer)) 31 | (define stx* (intro stx)) 32 | (with-syntax ([args (parse-args stx*)] 33 | [% (datum->syntax stx* '%)] 34 | [%1 (datum->syntax stx* '%1)] 35 | [body stx*]) 36 | (intro 37 | (syntax/loc stx 38 | (lambda args 39 | (define-syntax % (make-rename-transformer #'%1)) 40 | body))))) 41 | 42 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (module+ test 45 | (define chk (compose1 syntax->datum parse-afl)) 46 | (check-equal? (chk #'(+)) 47 | '(lambda () 48 | (define-syntax % (make-rename-transformer #'%1)) 49 | (+))) 50 | (check-equal? (chk #'(+ 2 %1 %1)) 51 | '(lambda (%1) 52 | (define-syntax % (make-rename-transformer #'%1)) 53 | (+ 2 %1 %1))) 54 | (check-equal? (chk #'(+ 2 %3 %2 %1)) 55 | '(lambda (%1 %2 %3) 56 | (define-syntax % (make-rename-transformer #'%1)) 57 | (+ 2 %3 %2 %1))) 58 | (check-equal? (chk #'(apply list* % %&)) 59 | '(lambda (%1 . %&) 60 | (define-syntax % (make-rename-transformer #'%1)) 61 | (apply list* % %&))) 62 | ) 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | 66 | ;; parse-args : Stx -> Formals-Stx 67 | (define (parse-args stx) 68 | ;; Filter the stxs to those that start with %, 69 | ;; find the maximum, find whether there is a 70 | ;; rest argument, and produce lambda formals 71 | ;; based on that. 72 | (define-values (max-num rest?) 73 | (find-arg-info stx)) 74 | (define datum-formals 75 | (append (for/list ([n (in-range 1 (add1 max-num))]) 76 | (string->symbol (format "%~v" n))) 77 | (cond [rest? '%&] 78 | [else '()]))) 79 | (datum->syntax stx datum-formals stx)) 80 | 81 | ;; find-arg-info : Any -> (Values Natural Boolean) 82 | (define (find-arg-info v) 83 | (match (maybe-syntax-e v) 84 | [(? symbol? sym) (find-arg-info/sym sym)] 85 | [(? pair? pair) (find-arg-info/pair pair)] 86 | [_ (return)])) 87 | 88 | ;; find-arg-info/sym : Symbol -> (Values Natural Boolean) 89 | (define (find-arg-info/sym sym) 90 | (define str (symbol->string sym)) 91 | (match str 92 | ["%" (return #:max-num 1)] 93 | ["%&" (return #:rest? #t)] 94 | [(regexp #px"^%\\d$") 95 | (return #:max-num (string->number (substring str 1)))] 96 | [_ (return)])) 97 | 98 | ;; find-arg-info/pair : 99 | ;; (Cons Symbol Symbol) -> (Values Natural Boolean) 100 | (define (find-arg-info/pair pair) 101 | (define-values (car.max-num car.rest?) 102 | (find-arg-info (car pair))) 103 | (define-values (cdr.max-num cdr.rest?) 104 | (find-arg-info (cdr pair))) 105 | (return #:max-num (max car.max-num cdr.max-num) 106 | #:rest? (or car.rest? cdr.rest?))) 107 | 108 | (define (return #:max-num [max-num 0] #:rest? [rest? #f]) 109 | (values max-num rest?)) 110 | 111 | (define (maybe-syntax-e stx) 112 | (cond [(syntax? stx) (syntax-e stx)] 113 | [else stx])) 114 | -------------------------------------------------------------------------------- /clojure/repl.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide apropos) 4 | 5 | ;; (U String Regexp) -> (List Symbol) 6 | ;; lookup names in the current namespace 7 | (define (apropos search-term) 8 | (filter (λ (sym) 9 | (define str (symbol->string sym)) 10 | (if (regexp? search-term) 11 | (regexp-match search-term str) 12 | (equal? search-term str))) 13 | (namespace-mapped-symbols))) 14 | 15 | -------------------------------------------------------------------------------- /clojure/string.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; String functions 4 | 5 | (module+ test (require rackunit)) 6 | 7 | (define upper-case string-upcase) 8 | (define lower-case string-downcase) 9 | 10 | ;; String -> String 11 | ;; capitalize the first character and down the rest 12 | (define (capitalize str) 13 | (cond [(= (string-length str) 0) 14 | str] 15 | [(= (string-length str) 1) 16 | (string-upcase str)] 17 | [(> (string-length str) 1) 18 | (string-append (string-upcase (substring str 0 1)) 19 | (string-downcase (substring str 1)))])) 20 | 21 | (module+ test 22 | (check-equal? (capitalize "") "") 23 | (check-equal? (capitalize "a") "A") 24 | (check-equal? (capitalize "MiXeD cAsE") "Mixed case") 25 | (check-equal? (capitalize "mIxEd CaSe") "Mixed case")) 26 | 27 | -------------------------------------------------------------------------------- /clojure/tests/test.rkt: -------------------------------------------------------------------------------- 1 | #lang clojure 2 | 3 | (require rackunit 4 | racket/list 5 | racket/stream 6 | (only-in racket/match (== =:))) 7 | 8 | (prn [1 2 3]) 9 | (check-true (vector? [1 2 3])) 10 | (check-true (vector? '[1 2 3])) 11 | (check-true (immutable? [1 2 3])) 12 | (check-true (immutable? '[1 2 3])) 13 | (check-true (immutable? (vector 1 2 3))) 14 | (check-equal? [1,2,3] [1 2 3]) 15 | (check-equal? [1 2 (+ 1 2)] [1 2 3]) 16 | (check-equal? '[1 2 (+ 1 2)] [1 2 '(+ 1 2)]) 17 | (check-equal? [1 2 [3]] (vector 1 2 (vector 3))) 18 | 19 | (prn {:a 5 :b 7}) 20 | (prn {:a 5, :b 7}) 21 | (check-equal? {:a 5 :b 7} (hash-map :a 5 :b 7)) 22 | (check-pred map? {:a 5 :b 7}) 23 | (check-pred map? '{:a 5 :b 7}) 24 | (check-equal? '{:a 5 :b 7} {:a 5 :b 7}) 25 | (check-equal? #{:a 1 :b (+ 1 2)} #{:a 1 :b 3}) 26 | (check-equal? '#{:a 1 :b (+ 1 2)} #{:a 1 :b '(+ 1 2)}) 27 | 28 | (check-pred char? \a) 29 | 30 | (check-pred set? #{1 2 3}) 31 | (check-pred set? '#{1 2 3}) 32 | (check-equal? #{1 2 3} (hash-set 1 2 3)) 33 | (check-equal? '#{1 2 3} (hash-set 1 2 3)) 34 | (check-equal? #{1 2 (+ 1 2)} #{1 2 3}) 35 | (check-equal? '#{1 2 (+ 1 2)} #{1 2 '(+ 1 2)}) 36 | (check-equal? #{1 2 #{3}} (hash-set 1 2 (hash-set 3))) 37 | 38 | (def foo 3) 39 | foo 40 | 41 | (do 3 5) 42 | 43 | (let [x 3 y 5] 44 | (+ x y)) 45 | 46 | ((fn this [x y] (+ x y)) 5 5) 47 | ((fn [x y] (+ x y)) 5 5) 48 | ((fn [x] (if (zero? x) 1 (* x (recur (- x 1))))) 5) 49 | ((fn ([x] (if (zero? x) 1 (* x (recur (- x 1))))) 50 | ([x y] (+ (recur x) (recur y)))) 51 | 3 2) 52 | 53 | (loop [x 3 y 5] 54 | (+ x y)) 55 | 56 | ;; TODO: make `nil` reader syntax 57 | (check-equal? (if #f 5) nil) 58 | 59 | (check-equal? 60 | (loop [x 5 n 1] 61 | (if (zero? x) 62 | n 63 | (recur (- x 1) (* x n)))) 64 | 120) 65 | 66 | (defn fact [x] 67 | (loop [x x n 1] 68 | (if (zero? x) 69 | n 70 | (recur (- x 1) (* x n))))) 71 | 72 | (check-equal? (fact 5) 120) 73 | 74 | (check-equal? (loop [x 1 y x] y) 1) 75 | 76 | ;; thrush operators 77 | (require (only-in racket/string string-split string-replace)) 78 | (check-equal? 79 | (-> "a b c d" 80 | string-upcase 81 | (string-replace "A" "X") 82 | (string-split " ") 83 | car) 84 | "X") 85 | 86 | (check-equal? 87 | (->> 5 (+ 3) (/ 2) (- 1)) 88 | (/ 3 4)) 89 | 90 | (check-equal? 91 | (->> 1 ((fn [x] (+ x 1)))) 92 | 2) 93 | 94 | ;; quote behavior 95 | (check-equal? (quote a b c d) (quote a)) 96 | (check-equal? (quote 5 a) 5) 97 | (check-equal? (-> 5 'a) 5) 98 | 99 | (check-equal? `(~(+ 1 2)) '(3)) 100 | 101 | ;; boolean and not 102 | (check-equal? (boolean true) true) 103 | (check-equal? (boolean false) false) 104 | (check-equal? (boolean nil) false) 105 | (check-equal? (boolean "a string") true) 106 | (check-equal? (boolean 0) true) 107 | (check-equal? (boolean 1) true) 108 | (check-equal? (not true) false) 109 | (check-equal? (not false) true) 110 | (check-equal? (not nil) true) 111 | (check-equal? (not "a string") false) 112 | (check-equal? (not 0) false) 113 | (check-equal? (not 1) false) 114 | (check-equal? (for/hash ((v (in-vector [true false nil [] {} '() #{} ""]))) 115 | (values v (boolean v))) 116 | {true true, false false, nil false, [] true, {} true, '() true, #{} true, "" true}) 117 | 118 | ;; if tests based on a post by Jay Fields 119 | (check-equal? "yes" (if true "yes")) 120 | (check-equal? "yes" (if true "yes" "no")) 121 | (check-equal? "no" (if false "yes" "no")) 122 | (check-equal? "no" (if nil "yes" "no")) 123 | (check-equal? "still true" (if -1 "still true" "false")) 124 | (check-equal? "still true" (if 0 "still true" "false")) 125 | (check-equal? "still true" (if [] "still true" "false")) 126 | (check-equal? "still true" (if (list) "still true" "false")) 127 | 128 | ;; cond tests 129 | (defn factorial [n] 130 | (cond 131 | (<= n 1) 1 132 | :else (* n (factorial (dec n))))) 133 | (check-equal? 120 (factorial 5)) 134 | 135 | (check-equal? "B" (let [grade 85] 136 | (cond 137 | (>= grade 90) "A" 138 | (>= grade 80) "B" 139 | (>= grade 70) "C" 140 | (>= grade 60) "D" 141 | :else "F"))) 142 | 143 | (defn pos-neg-or-zero [n] 144 | (cond 145 | (< n 0) "negative" 146 | (> n 0) "positive" 147 | :else "zero")) 148 | (check-equal? "positive" (pos-neg-or-zero 5)) 149 | (check-equal? "negative" (pos-neg-or-zero -1)) 150 | (check-equal? "zero" (pos-neg-or-zero 0)) 151 | 152 | (check-equal? (cond) nil) 153 | (check-equal? (cond false 5) nil) 154 | 155 | (check-equal? (nth ["a" "b" "c" "d"] 0) "a") 156 | (check-equal? (nth (list "a" "b" "c" "d") 0) "a") 157 | (check-equal? (nth ["a" "b" "c" "d"] 1) "b") 158 | (check-equal? (nth [] 0 "nothing found") "nothing found") 159 | (check-equal? (nth [0 1 2] 77 1337) 1337) 160 | (check-equal? (nth "Hello" 0) #\H) 161 | (check-equal? (nth '(1 2 3) 0) 1) 162 | 163 | (check-equal? (zipmap [:a :b :c :d :e] [1 2 3 4 5]) 164 | {:a 1, :b 2, :c 3, :d 4, :e 5}) 165 | (check-equal? (zipmap [:a :b :c] [1 2 3 4]) 166 | {:a 1, :b 2, :c 3}) 167 | (check-equal? (zipmap [:a :b :c] [1 2]) 168 | {:a 1, :b 2}) 169 | 170 | (check-equal? (get {:a 1 :b 2} :a) 1) 171 | (check-match (keys {:a 1 :b 2}) (or (=: '(:a :b)) (=: '(:b :a)))) 172 | (check-match (vals {:a 1 :b 2}) (or (=: '(1 2)) (=: '(2 1)))) 173 | (let [m {:a 1 :b 2}] 174 | (check-equal? (zipmap (keys m) (vals m)) m)) 175 | (check-equal? (assoc {:a 1 :b 2} :c 3) {:a 1 :b 2 :c 3}) 176 | (check-equal? (dissoc {:a 1 :b 2} :b) {:a 1}) 177 | 178 | (check-equal? (disj #{:a :b} :a) #{:b}) 179 | 180 | (check-true (= {:a [1 2 3] :b #{:x :y} :c {:foo 1 :bar 2}} 181 | {:a [1 2 3] :b #{:y :x} :c {:bar 2 :foo 1}})) 182 | (check-false (= 4 4.0)) 183 | (check-true (== 4 4.0)) 184 | 185 | (check-equal? (str) "") 186 | (check-equal? (str "some string") "some string") 187 | (check-equal? (str nil) "") 188 | (check-equal? (str 1) "1") 189 | (check-equal? (str 1 2 3) "123") 190 | (check-equal? (str 1 'symbol :keyword) "1symbol:keyword") 191 | (check-equal? (apply str '(1 2 3)) "123") 192 | (check-equal? (str [1 2 3]) "[1 2 3]") 193 | (check-pred immutable? (str "I" " should be " "immutable")) 194 | 195 | (check-equal? (+ 1 2 #_(this is ignored)) 3) 196 | 197 | (check-equal? (pr-str) "") 198 | (check-equal? (pr-str "foo") "\"foo\"") 199 | (check-equal? (pr-str '()) "()") 200 | (check-equal? (pr-str []) "[]") 201 | (check-equal? (pr-str {}) "{}") 202 | (check-match (pr-str {:foo "hello" :bar 34.5}) 203 | (or "{:foo \"hello\" :bar 34.5}" 204 | "{:foo \"hello\", :bar 34.5}" 205 | "{:bar 34.5 :foo \"hello\"}" 206 | "{:bar 34.5, :foo \"hello\"}")) 207 | (check-match (pr-str #{1 2 3}) 208 | (or "#{1 2 3}" "#{1 3 2}" 209 | "#{2 1 3}" "#{2 3 1}" 210 | "#{3 1 2}" "#{3 2 1}")) 211 | (check-equal? (pr-str ['a :b "\n" \space "c"]) "[a :b \"\\n\" \\space \"c\"]") 212 | (check-equal? (pr-str [1 2 3 4 5]) "[1 2 3 4 5]") 213 | (check-equal? (pr-str '(a b foo :bar)) "(a b foo :bar)") 214 | (check-equal? (pr-str 1 2) "1 2") 215 | 216 | (check-equal? (stream->list (map #(* 2 %) (range 0 10))) 217 | '(0 2 4 6 8 10 12 14 16 18)) 218 | (check-equal? (#(+ %1 %2 %3) 1 2 3) 219 | 6) 220 | (check-equal? (#(apply list* % %&) 1 '(2 3)) 221 | '(1 2 3)) 222 | (check-equal? (let [lambda "not lambda" define-syntax "not define-syntax"] 223 | (#(do %) 3)) 224 | 3) 225 | 226 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define collection 'multi) 4 | (define deps '("base" "rackunit-lib")) 5 | 6 | --------------------------------------------------------------------------------