stx-sort.rkt (2955B)
1 #lang racket 2 3 (provide ~sort 4 ~sort-seq 5 ~key) 6 7 ;; Note: when using nested ~sort, the inner sort is not performed during the 8 ;; first pass for the outer ~sort. Once the values for the outer ~sort have been 9 ;; gathered and sorted, then the innder ~sort is applied. This means that the 10 ;; comparison operator for the outer ~sort should work with unsorted 11 ;; sub-sequences.s 12 13 (require syntax/parse 14 "aliases.rkt" 15 syntax/stx 16 racket/stxparam 17 (for-syntax racket/syntax)) 18 19 (define-for-syntax sort-scope (make-syntax-introducer)) 20 (define-syntax-parameter current-key-id #f) 21 22 (define-for-syntax (~sort-ish op*) 23 (pattern-expander 24 (λ (stx) 25 (syntax-case stx (…) 26 [(self pat …) 27 (if (syntax-parameter-value #'current-key-id) 28 #`(#,@op* _ …) 29 #`(~and (#,@op* tmp …) 30 (~parse (pat …) 31 (sort/stx self #'(tmp …) pat))))])))) 32 (define-syntax ~sort (~sort-ish #'{})) 33 34 (define-syntax ~sort-seq (~sort-ish #'{~seq})) 35 36 (define-syntax (sort/stx stx) 37 (syntax-case stx () 38 [(_ ctx stxlist pat) 39 #'(syntax-parameterize 40 ([current-key-id (generate-temporary #'key)]) 41 (def-cls tmpcls pat) 42 (and (syntax-parse stxlist [({~var || tmpcls} …) #t] [_ (displayln (format "Failed to parse ~a as ~a." stxlist 'pat)) #f]) 43 (sort (syntax->list stxlist) 44 (λ (a b) 45 (cond 46 [(and (symbol? a) (symbol? b)) (symbol<? a b)] 47 [(and (number? a) (number? b)) (< a b)] 48 [else (number? a)])) ; numbers come first in the order 49 #:key (do-parse tmpcls))))])) 50 51 (define-syntax (def-cls stx) 52 (syntax-case stx () 53 [(_ tmpcls pat) 54 (with-syntax ([key (syntax-parameter-value 55 #'current-key-id)]) 56 #'(define-syntax-class tmpcls 57 ;; I can't seem to manage to establish reliable communication between 58 ;; the ~sort and the ~key. So here we're relying on the fact that 59 ;; #:attributes is actually unhygienic, in order to get a handle on 60 ;; the key as defined by ~key. 61 #:attributes (key) 62 (pattern pat)))])) 63 64 (define-syntax (do-parse stx) 65 (syntax-case stx () 66 [(_ tmpcls) 67 (with-syntax ([x.key (format-id #'x "x.~a" (syntax-parameter-value 68 #'current-key-id))]) 69 #'(syntax-parser 70 [(~var x tmpcls) (syntax-e #'x.key)]))])) 71 72 (define-syntax ~key 73 (pattern-expander 74 (λ (stx) 75 (syntax-case stx () 76 [(self pat) 77 (if (syntax-parameter-value #'current-key-id) 78 (with-syntax ([key (syntax-parameter-value #'current-key-id)]) 79 #`(~and pat key)) 80 #'(~and pat _))])))) 81 82 #;(syntax-parse #'([a 3] [c 1] [b 2]) 83 [{~sort [{~key k} v] …} 84 #'([k . v] …)])