85 lines
2.9 KiB
Racket
85 lines
2.9 KiB
Racket
#lang racket
|
|
|
|
(provide ~sort
|
|
~sort-seq
|
|
~key)
|
|
|
|
;; Note: when using nested ~sort, the inner sort is not performed during the
|
|
;; first pass for the outer ~sort. Once the values for the outer ~sort have been
|
|
;; gathered and sorted, then the innder ~sort is applied. This means that the
|
|
;; comparison operator for the outer ~sort should work with unsorted
|
|
;; sub-sequences.s
|
|
|
|
(require syntax/parse
|
|
"aliases.rkt"
|
|
syntax/stx
|
|
racket/stxparam
|
|
(for-syntax racket/syntax))
|
|
|
|
(define-for-syntax sort-scope (make-syntax-introducer))
|
|
(define-syntax-parameter current-key-id #f)
|
|
|
|
(define-for-syntax (~sort-ish op*)
|
|
(pattern-expander
|
|
(λ (stx)
|
|
(syntax-case stx (…)
|
|
[(self pat …)
|
|
(if (syntax-parameter-value #'current-key-id)
|
|
#`(#,@op* _ …)
|
|
#`(~and (#,@op* tmp …)
|
|
(~parse (pat …)
|
|
(sort/stx self #'(tmp …) pat))))]))))
|
|
(define-syntax ~sort (~sort-ish #'{}))
|
|
|
|
(define-syntax ~sort-seq (~sort-ish #'{~seq}))
|
|
|
|
(define-syntax (sort/stx stx)
|
|
(syntax-case stx ()
|
|
[(_ ctx stxlist pat)
|
|
#'(syntax-parameterize
|
|
([current-key-id (generate-temporary #'key)])
|
|
(def-cls tmpcls pat)
|
|
(and (syntax-parse stxlist [({~var || tmpcls} …) #t] [_ (displayln (format "Failed to parse ~a as ~a." stxlist 'pat)) #f])
|
|
(sort (syntax->list stxlist)
|
|
(λ (a b)
|
|
(cond
|
|
[(and (symbol? a) (symbol? b)) (symbol<? a b)]
|
|
[(and (number? a) (number? b)) (< a b)]
|
|
[else (number? a)])) ; numbers come first in the order
|
|
#:key (do-parse tmpcls))))]))
|
|
|
|
(define-syntax (def-cls stx)
|
|
(syntax-case stx ()
|
|
[(_ tmpcls pat)
|
|
(with-syntax ([key (syntax-parameter-value
|
|
#'current-key-id)])
|
|
#'(define-syntax-class tmpcls
|
|
;; I can't seem to manage to establish reliable communication between
|
|
;; the ~sort and the ~key. So here we're relying on the fact that
|
|
;; #:attributes is actually unhygienic, in order to get a handle on
|
|
;; the key as defined by ~key.
|
|
#:attributes (key)
|
|
(pattern pat)))]))
|
|
|
|
(define-syntax (do-parse stx)
|
|
(syntax-case stx ()
|
|
[(_ tmpcls)
|
|
(with-syntax ([x.key (format-id #'x "x.~a" (syntax-parameter-value
|
|
#'current-key-id))])
|
|
#'(syntax-parser
|
|
[(~var x tmpcls) (syntax-e #'x.key)]))]))
|
|
|
|
(define-syntax ~key
|
|
(pattern-expander
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(self pat)
|
|
(if (syntax-parameter-value #'current-key-id)
|
|
(with-syntax ([key (syntax-parameter-value #'current-key-id)])
|
|
#`(~and pat key))
|
|
#'(~and pat _))]))))
|
|
|
|
#;(syntax-parse #'([a 3] [c 1] [b 2])
|
|
[{~sort [{~key k} v] …}
|
|
#'([k . v] …)])
|