diff --git a/collects/honu/core/private/util.rkt b/collects/honu/core/private/util.rkt index 8f7d954b1f..9f43ac19f9 100644 --- a/collects/honu/core/private/util.rkt +++ b/collects/honu/core/private/util.rkt @@ -1,15 +1,18 @@ -#lang scheme +#lang racket/base -(provide (except-out (all-defined-out) test)) -(require "debug.rkt") +(provide (except-out (all-defined-out) test-delimiter)) +(require "debug.rkt" + tests/eli-tester + racket/match + (for-syntax racket/base) + syntax/stx + racket/list) #; (provide delim-identifier=? extract-until call-values) -(require syntax/stx - scheme/list) (define (delim-identifier=? a b) (eq? (syntax-e a) (syntax-e b))) @@ -50,7 +53,7 @@ (define (drop-last lst) (take lst (sub1 (length lst)))) -(define (test) +(define (test-delimiter) (let* ([original #'(a b c d e)] [delimiter #'c] [expected-before #'(a b)] @@ -71,4 +74,41 @@ (debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit)) )))) +#; (test) + +;; better version of caddadadr-type functions +(define-syntax (list-match stx) + (define (convert-pattern pattern) + (syntax-case pattern () + [(x ...) (with-syntax ([(x* ...) (map convert-pattern (syntax->list #'(x ...)))]) + #'(list x* ...))] + [x #'x])) + (define (extract-variable pattern) + (define (non-wildcard-identifier? x) + (and (identifier? x) + (not (eq? (syntax-e x) '_)))) + (syntax-case pattern () + [(a x ...) + (if (non-wildcard-identifier? #'a) + #'a + (or (extract-variable #'a) + (extract-variable #'(x ...))))] + [x (if (non-wildcard-identifier? #'x) + #'x + #f)])) + (syntax-case stx () + [(_ pattern expression) + (with-syntax ([match-pattern (convert-pattern #'pattern)] + [match-variable (extract-variable #'pattern)]) + #'(match expression + [match-pattern match-variable]))])) + +#; +(test + (list-match a '(1 2 3)) => '(1 2 3) + (list-match (a _ ...) '(1 2 3)) => 1 + (list-match (_ _ a ...) '(1 2 3 4)) => '(3 4) + (list-match ((_ a _ ...) _ ...) '((1 2 3 4) 5 6)) => 2 + (list-match ((_ _ a _ ...) _ ...) '((7 6 5 4 3 2 1) 8 9)) => 5 + )