suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

use racket. add list-match utility

Browse Source
This commit is contained in:
Jon Rafkind 2010-10-25 12:10:03 -06:00
parent 4bf3ca44d0
commit b8ad3ad1cb
1 changed files with 46 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
collects/honu/core/private/util.rkt
View File

@ -1,15 +1,18 @@
#lang scheme #lang racket/base
(provide (except-out (all-defined-out) test)) (provide (except-out (all-defined-out) test-delimiter))
(require "debug.rkt") (require "debug.rkt"
tests/eli-tester
racket/match
(for-syntax racket/base)
syntax/stx
racket/list)
#; #;
(provide delim-identifier=? (provide delim-identifier=?
extract-until extract-until
call-values) call-values)
(require syntax/stx
scheme/list)
(define (delim-identifier=? a b) (define (delim-identifier=? a b)
(eq? (syntax-e a) (syntax-e b))) (eq? (syntax-e a) (syntax-e b)))
@ -50,7 +53,7 @@
(define (drop-last lst) (define (drop-last lst)
(take lst (sub1 (length lst)))) (take lst (sub1 (length lst))))
(define (test) (define (test-delimiter)
(let* ([original #'(a b c d e)] (let* ([original #'(a b c d e)]
[delimiter #'c] [delimiter #'c]
[expected-before #'(a b)] [expected-before #'(a b)]
@ -71,4 +74,41 @@
(debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit)) (debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
)))) ))))
#;
(test) (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
)