[racket] define-match-expander
Hi,
I have introduced modules and "conventions".
Identifiers in a pattern that begins with sym must match symbols
Identifiers in a pattern that begins with r or s must match numbers.
Identifiers in a pattern that begins with m or n must match exact integers.
The conventions are hard coded, so a nice exension would we
to replace the hard coded conventions with user-defineable ones.
Something like define-conventions for syntax-parse.
http://docs.racket-lang.org/syntax/Literal_Sets_and_Conventions.html?q=syntax-parse#%28form._%28%28lib._syntax%2Fparse..rkt%29._define-conventions%29%29
/Jens Axel
#lang racket
(require (for-syntax racket/string racket/match)
rackunit)
(module+ test (require rackunit))
(module conventions racket
(provide find-convention-type conventions
(struct-out convention))
(require racket/stxparam (for-template racket))
; A CONVENTION consists of a predicate
; pred? : string -> boolean
; and a syntax object representing an identifier
; bound to a predicate e.g #'number?
(struct convention (pred? type))
(define (make-begins-with-pred s)
(λ (t) (regexp-match (~a "^" s) t)))
(define conventions
(list (convention (make-begins-with-pred "sym") #'symbol?)
(convention (make-begins-with-pred "r") #'number?)
(convention (make-begins-with-pred "s") #'number?)
(convention (make-begins-with-pred "m") #'exact-integer?)
(convention (make-begins-with-pred "n") #'exact-integer?)))
(define (find-convention-type s)
(for/or ([c (in-list conventions)])
(and ((convention-pred? c) s)
(convention-type c)))))
(module+ test (require (submod ".." conventions))
(check-equal? (syntax->datum (find-convention-type "r")) 'number?)
(check-equal? (syntax->datum (find-convention-type "sym")) 'symbol?)
(check-equal? (find-convention-type "foo") #f))
(module colon-match-helpers racket
(provide type-str->stx-type-pred id:type? parse-pat-str)
(require (only-in lang/htdp-intermediate-lambda string-contains?)
(for-template (only-in racket number? string? symbol? list?
vector? boolean? procedure?)))
(define (type-str->stx-type-pred type-str)
(match type-str
["num" #'number?]
["int" #'integer?]
["str" #'string?]
["sym" #'symbol?]
["lst" #'list?]
["vec" #'vector?]
["bool" #'boolean?]
["proc" #'procedure?]
[_ #f]))
(define (split str) (string-split str ":"))
(define (parse-pat-str pat-str stx)
(match (split pat-str)
[(list pat-name-strs ... type-str)
(with-syntax ([type-pred (type-str->stx-type-pred type-str)]
[pat-name (datum->syntax stx (string->symbol
(string-join pat-name-strs ":")))])
#'(? type-pred pat-name))]))
(define (id:type? str)
(and (string-contains? ":" str)
(<= 2 (length (split str)))
(type-str->stx-type-pred (last (split str))))))
(module colon-match racket
(provide :match :pat)
(require (for-syntax racket/match (submod ".." colon-match-helpers)
(submod ".." conventions)))
(define-match-expander :pat
(lambda (stx)
(define (rewrite-id pat)
(let* ([pat-sym (syntax->datum pat)]
[pat-str (symbol->string pat-sym)])
(cond
[(id:type? pat-str) (parse-pat-str pat-str stx)]
[(find-convention-type pat-str) => (λ (pred)
(with-syntax ([pred pred]
[name
(datum->syntax stx pat-sym)])
#'(? pred name)))]
[else pat])))
(define (rewrite pat_0)
(syntax-case pat_0 ()
[pat (identifier? #'pat) (rewrite-id #'pat)]
[pat #'pat]))
(syntax-case stx ()
[(_ pat)
(identifier? #'pat) (rewrite-id #'pat)]
[(_ #(pat ...)) (syntax/loc stx (vector (:pat pat) ...))]
[(_ (pat0 pat ...)) (with-syntax ([(p ...) (map rewrite
(syntax->list #'(pat0 pat ...)))])
(syntax/loc stx (p ...)))]
[(_ #&pat) (with-syntax ([p (rewrite #'pat)])
(syntax/loc stx #&p))]
[(_ pat)
(prefab-struct-key (syntax-e #'pat))
(let ([key-datum (prefab-struct-key (syntax-e #'pat))])
(match (struct->vector (syntax-e #'pat))
[(vector struct:key-datum subpats ...)
(datum->syntax stx (apply make-prefab-struct key-datum
(map rewrite subpats)))]))]
[(_ pat) #'pat])))
(define-syntax (:match stx)
(syntax-case stx ()
[(:match val-expr [pat . more] ...)
(with-syntax ([(new-pat ...)
(for/list ([pat-stx (in-list (syntax->list #'(pat ...)))])
(datum->syntax pat-stx `(:pat ,(syntax->datum
pat-stx))))])
(syntax/loc stx (match val-expr [new-pat . more] ...)))])))
(module+ test (require (submod ".." colon-match))
(check-equal? (match 1 [(:pat n:num) n]) 1)
(check-equal? (match 'x [(:pat n:num) n] [_ 2]) 2)
(check-equal? (match "string" [(:pat s:str) s]) "string")
(check-equal? (match 'x [(:pat s:str) s] [_ 2]) 2)
(check-equal? (match (list 1 2 3) [(:pat l:lst) l]) (list 1 2 3))
(check-equal? (match 'x [(:pat l:lst) l] [_ 2]) 2)
(check-equal? (match 'x [(:pat l) l]) 'x)
(check-equal? (match '(2 x "foo" (3 4)) [(:pat (list n t f l)) (list
n t f l)]) '(2 x "foo" (3 4)))
(check-equal? (match '(42 x) [(:pat (list n:num s:sym)) (list n s)])
'(42 x))
(check-equal? (match '(42 x) [(:pat (list n:num s:sym)) (list n s)]) '(42 x))
(check-equal? (:match '(42 x) [(list n:num s:sym) (list n s)]) '(42 x))
(check-equal? (:match 1 [n:num n]) 1)
(check-equal? (:match 'x [n:num n] [_ 2]) 2)
(check-equal? (:match "string" [s:str s]) "string")
(check-equal? (:match 'x [s:str s] [_ 2]) 2)
(check-equal? (:match (list 1 2 3) [l:lst l]) (list 1 2 3))
(check-equal? (:match 'x [l:lst l] [_ 2]) 2)
(check-equal? (:match (vector 1 2 3) [v:vec v]) (vector 1 2 3))
(check-equal? (:match 'x [v:vec v] [_ 2]) 2)
(check-equal? (:match #t [b:bool b]) #t)
(check-equal? (:match #f [b:bool b]) #f)
(check-equal? (:match 'x [b:bool b] [_ 2]) 2)
(check-equal? (:match 'x [l l]) 'x)
(check-equal? (:match (list 1 "2" '|3|)
[(list a:1:num b:2:str c:3:sym)
(list a:1 (string->number b:2)
(string->number (symbol->string c:3)))])
(list 1 2 3))
(check-equal? (:match 42.0 [r r]) 42.0)
(check-equal? (:match 42.0 [n n] [r #t]) #t)
(check-equal? (:match 'x [r r] [_ 42]) 42)
(check-equal? (:match 'x [sym123 sym123]) 'x))
(require (submod "." colon-match))
2013/12/30 Alexander D. Knauth <alexander at knauth.org>:
> I got it to work for prefab structures. Is there anything else I should put
> in?
>
> (define (rewrite pat_0)
> (syntax-case pat_0 ()
> [pat (identifier? #'pat) (rewrite-id #'pat stx)]
> [(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx (p ...)))]
> [#(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx #(p ...)))]
> [#&pat
> (with-syntax ([p (rewrite #'pat)])
> (syntax/loc stx #&p))]
> [pat (prefab-struct-key (syntax-e #'pat))
> (let ([key-datum (prefab-struct-key (syntax-e #'pat))])
> (match (struct->vector (syntax-e #'pat))
> [(vector struct:key-datum subpats ...)
> (datum->syntax stx (apply make-prefab-struct key-datum (map
> rewrite subpats)))]))]
> [pat #'pat]))
>
> (check-equal? (:match #s(key-datum 1 2 3)
> [`#s(key-datum ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
> (check-equal? (:match #s(key-datum_0 1 2 3)
> [`#s(key-datum_0 ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
> The whole thing is here:
> (by the way I also made it so that something:something-else:num works as a
> pattern with the name something:something-else.)
>
> #lang racket
>
> (require rackunit)
> (require (for-syntax
> (only-in lang/htdp-intermediate-lambda
> string-contains?)
> racket/list
> racket/string
> racket/match))
>
> (begin-for-syntax
> (define (type-str->stx-type-pred type-str)
> (match type-str
> ["num" #'number?]
> ["int" #'integer?]
> ["str" #'string?]
> ["sym" #'symbol?]
> ["lst" #'list?]
> ["vec" #'vector?]
> ["bool" #'boolean?]
> ["proc" #'procedure?]
> [_ #f]))
>
> (define (split str)
> (string-split str ":"))
>
> (define (rewrite-id pat stx)
> (let* ([pat-sym (syntax->datum pat)]
> [pat-str (symbol->string pat-sym)])
> (if (id:type? pat-str)
> (parse-pat-str pat-str stx)
> pat)))
>
> (define (parse-pat-str pat-str stx)
> (match (split pat-str)
> [(list pat-name-strs ... type-str)
> (with-syntax ([type-pred (type-str->stx-type-pred type-str)]
> [pat-name (datum->syntax stx (string->symbol
> (string-join pat-name-strs ":")))])
> #'(? type-pred pat-name))]))
>
> (define (id:type? str)
> (and (string-contains? ":" str)
> (<= 2 (length (split str)))
> (type-str->stx-type-pred (last (split str)))))
> )
>
> (define-match-expander :pat
> (lambda (stx)
> (define (rewrite pat_0)
> (syntax-case pat_0 ()
> [pat (identifier? #'pat) (rewrite-id #'pat stx)]
> [(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx (p ...)))]
> [#(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx #(p ...)))]
> [#&pat
> (with-syntax ([p (rewrite #'pat)])
> (syntax/loc stx #&p))]
> [pat (prefab-struct-key (syntax-e #'pat))
> (let ([key-datum (prefab-struct-key (syntax-e #'pat))])
> (match (struct->vector (syntax-e #'pat))
> [(vector struct:key-datum subpats ...)
> (datum->syntax stx (apply make-prefab-struct key-datum
> (map rewrite subpats)))]))]
> [pat #'pat]))
> (syntax-case stx ()
> [(_ pat) (rewrite #'pat)])))
>
> (define-syntax (:match stx)
> (syntax-case stx ()
> [(:match val-expr [pat . more] ...)
> (with-syntax ([(new-pat ...) (for/list ([pat-stx (in-list (syntax->list
> #'(pat ...)))])
> (datum->syntax pat-stx `(:pat
> ,(syntax->datum pat-stx))))])
> #'(match val-expr [new-pat . more] ...))]))
>
>
> (check-equal? (:match 1 [n:num n]) 1)
> (check-equal? (:match 'x [n:num n] [_ 2]) 2)
>
> (check-equal? (:match "string" [s:str s]) "string")
> (check-equal? (:match 'x [s:str s] [_ 2]) 2)
>
> (check-equal? (:match (list 1 2 3) [l:lst l]) (list 1 2 3))
> (check-equal? (:match 'x [l:lst l] [_ 2]) 2)
>
> (check-equal? (:match (vector 1 2 3) [v:vec v]) (vector 1 2 3))
> (check-equal? (:match 'x [v:vec v] [_ 2]) 2)
>
> (check-equal? (:match #t [b:bool b]) #t)
> (check-equal? (:match #f [b:bool b]) #f)
> (check-equal? (:match 'x [b:bool b] [_ 2]) 2)
>
> (check-equal? (:match 'x [l l]) 'x)
>
> (check-equal? (:match '(2 x "foo" (3 4)) [(list n s f l) (list n s f l)])
> '(2 x "foo" (3 4)))
> (check-equal? (:match '(42 x) [(list n:num s:sym) (list n s)]) '(42 x))
>
> (check-equal? (:match (list 1 "2" '|3|)
> [(list a:1:num b:2:str c:3:sym)
> (list a:1 (string->number b:2) (string->number
> (symbol->string c:3)))])
> (list 1 2 3))
>
> (check-equal? (:match '(1 2 #(1 2 3 (1 2 3 4)))
> [(list a:num b:num (vector c:num d:num e:num (list
> f:num g:num h:num i:num)))
> (list a b c d e f g h i)])
> (list 1 2 1 2 3 1 2 3 4))
>
> (check-equal? (:match '(1 2 #(1 2 3 (1 2 3 #&4)))
> [`(,a:num ,b:num #(,c:num ,d:num ,e:num (,f:num ,g:num
> ,h:num #&,i:num)))
> (list a b c d e f g h i)])
> (list 1 2 1 2 3 1 2 3 4))
>
> (check-equal? (:match #s(key-datum 1 2 3)
> [`#s(key-datum ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
> (check-equal? (:match #s(key-datum_0 1 2 3)
> [`#s(key-datum_0 ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
>
> On Dec 29, 2013, at 6:53 PM, Alexander D. Knauth wrote:
>
> I got it to work for lists, vectors, and boxes, but I'm having trouble for
> prefab structure types.
> (by the way I renamed the rewrite function to rewrite-id and made a new
> rewrite function that deals with lists, vectors, boxes, and prefab
> structures.)
>
> Here's my new rewrite function:
>
> (define (rewrite pat_0)
> (syntax-case pat_0 ()
> [pat (identifier? #'pat) (rewrite-id #'pat stx)]
> [(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx (p ...)))]
> [#(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx #(p ...)))]
> [#&pat
> (with-syntax ([p (rewrite #'pat)])
> (syntax/loc stx #&p))]
> [#s(key-datum pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx #s(key-datum p ...)))]
> [pat #'pat]))
>
> the problem is that I can't make key-datum a pattern. For example this
> works:
>
> (check-equal? (:match #s(key-datum 1 2 3)
> [`#s(key-datum ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
> But this doesn't (because a, b, and c are undefined)
>
> (check-equal? (:match #s(key-datum_0 1 2 3)
> [`#s(key-datum_0 ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
> How do I turn the key-datum in #s(key-datum pat ...) into a syntax-case
> pattern so that it recognizes all prefab structures instead of just
> #s(key-datum pat ...) as opposed to #s(other-key-datum pat ...)?
>
> Here's the whole thing:
>
> #lang racket
>
> (require rackunit)
> (require (for-syntax
> (only-in lang/htdp-intermediate-lambda
> string-contains?)
> racket/string
> racket/match))
>
> (begin-for-syntax
> (define (type-str->stx-type-pred type-str)
> (match type-str
> ["num" #'number?]
> ["int" #'integer?]
> ["str" #'string?]
> ["sym" #'symbol?]
> ["lst" #'list?]
> ["vec" #'vector?]
> ["bool" #'boolean?]
> ["proc" #'procedure?]
> [_ #f]))
>
> (define (split str) (string-split str ":"))
>
> (define (rewrite-id pat stx)
> (let* ([pat-sym (syntax->datum pat)]
> [pat-str (symbol->string pat-sym)])
> (if (id:type? pat-str)
> (parse-pat-str pat-str stx)
> pat)))
>
> (define (parse-pat-str pat-str stx)
> (match (split pat-str)
> [(list pat-name-str type-str)
> (with-syntax ([type-pred (type-str->stx-type-pred type-str)]
> [pat-name (datum->syntax stx (string->symbol
> pat-name-str))])
> #'(? type-pred pat-name))]))
>
> (define (id:type? str)
> (and (string-contains? ":" str)
> (= 2 (length (split str)))
> (type-str->stx-type-pred (cadr (split str)))))
> )
>
> (define-match-expander :pat
> (lambda (stx)
> (define (rewrite pat_0)
> (syntax-case pat_0 ()
> [pat (identifier? #'pat) (rewrite-id #'pat stx)]
> [(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx (p ...)))]
> [#(pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx #(p ...)))]
> [#&pat
> (with-syntax ([p (rewrite #'pat)])
> (syntax/loc stx #&p))]
> [#s(key-datum pat ...)
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
> (syntax/loc stx #s(key-datum p ...)))]
> [pat #'pat]))
> (syntax-case stx ()
> [(_ pat) (rewrite #'pat)])))
>
> (define-syntax (:match stx)
> (syntax-case stx ()
> [(:match val-expr [pat . more] ...)
> (with-syntax ([(new-pat ...) (for/list ([pat-stx (in-list (syntax->list
> #'(pat ...)))])
> (datum->syntax pat-stx `(:pat
> ,(syntax->datum pat-stx))))])
> #'(match val-expr [new-pat . more] ...))]))
>
>
> (check-equal? (:match 1 [n:num n]) 1)
> (check-equal? (:match 'x [n:num n] [_ 2]) 2)
>
> (check-equal? (:match "string" [s:str s]) "string")
> (check-equal? (:match 'x [s:str s] [_ 2]) 2)
>
> (check-equal? (:match (list 1 2 3) [l:lst l]) (list 1 2 3))
> (check-equal? (:match 'x [l:lst l] [_ 2]) 2)
>
> (check-equal? (:match (vector 1 2 3) [v:vec v]) (vector 1 2 3))
> (check-equal? (:match 'x [v:vec v] [_ 2]) 2)
>
> (check-equal? (:match #t [b:bool b]) #t)
> (check-equal? (:match #f [b:bool b]) #f)
> (check-equal? (:match 'x [b:bool b] [_ 2]) 2)
>
> (check-equal? (:match 'x [l l]) 'x)
>
> (check-equal? (:match '(2 x "foo" (3 4)) [(list n s f l) (list n s f l)])
> '(2 x "foo" (3 4)))
> (check-equal? (:match '(42 x) [(list n:num s:sym) (list n s)]) '(42 x))
>
> (check-equal? (:match '(1 2 #(1 2 3 (1 2 3 4)))
> [(list a:num b:num (vector c:num d:num e:num (list
> f:num g:num h:num i:num)))
> (list a b c d e f g h i)])
> (list 1 2 1 2 3 1 2 3 4))
>
> (check-equal? (:match '(1 2 #(1 2 3 (1 2 3 #&4)))
> [`(,a:num ,b:num #(,c:num ,d:num ,e:num (,f:num ,g:num
> ,h:num #&,i:num)))
> (list a b c d e f g h i)])
> (list 1 2 1 2 3 1 2 3 4))
>
> (check-equal? (:match #s(key-datum 1 2 3)
> [`#s(key-datum ,a:num ,b:num ,c:num) (list a b c)])
> (list 1 2 3))
>
> ;; this doesn't work:
> ;
> ;(check-equal? (:match #s(key-datum_0 1 2 3)
> ; [`#s(key-datum_0 ,a:num ,b:num ,c:num) (list a b c)])
> ; (list 1 2 3))
>
>
> On Dec 29, 2013, at 4:01 PM, Jens Axel Søgaard wrote:
>
> 2013/12/29 Alexander D. Knauth <alexander at knauth.org>:
>
> I was seeing if it would work with nested patterns and quasiquoted patterns
>
> and it didn't, so I had to change the rewrite function and use (vector?
>
> (syntax-e pat)) to check for a vector written like `#(,a:num ,b:num ,c:num).
>
>
> like this:
>
>
> (define (rewrite pat)
>
> (cond [(identifier? pat) (let* ([pat-sym (syntax->datum pat)]
>
> [pat-str (symbol->string pat-sym)])
>
> (if (id:type? pat-str)
>
> (parse-pat-str pat-str stx)
>
> pat))]
>
> [(syntax->list pat) (datum->syntax pat (map rewrite (syntax->list
>
> pat)))]
>
> [(vector? (syntax-e pat)) (datum->syntax pat (vector-map rewrite
>
> (syntax-e pat)))]
>
> [else (print pat) (newline) (error "I don't know what to do.
>
> given:" pat)]))
>
>
> For the vector thing, I had to put a special clause in that did a vector-map
>
> instead of a map.
>
>
> Is there any other stuff (like the #(1 2 3) notation for vectors) that I
>
> should be worried about,
>
>
> There are boxes and prefab structures. See the list here:
>
> http://docs.racket-lang.org/reference/stx-patterns.html?q=syntax-case#%28form._%28%28lib._racket%2Fprivate%2Fstxcase-scheme..rkt%29._syntax-case%29%29
>
> ... or is there another way to write the rewrite
>
> function to handle stuff like this that wouldn't require a cond case for
>
> every type of data that pat could be?
>
>
> I don't see a way around it.
>
> /Jens Axel
>
>
>
>
> The whole thing is here:
>
>
> #lang racket
>
>
> (require rackunit)
>
> (require (for-syntax
>
> (only-in lang/htdp-intermediate-lambda
>
> string-contains?)
>
> racket/string
>
> racket/match
>
> racket/vector))
>
>
> (begin-for-syntax
>
> (define (type-str->stx-type-pred type-str)
>
> (match type-str
>
> ["num" #'number?]
>
> ["str" #'string?]
>
> ["sym" #'symbol?]
>
> ["lst" #'list?]
>
> ["vec" #'vector?]
>
> ["bool" #'boolean?]
>
> ["proc" #'procedure?]
>
> [_ #f]))
>
>
> (define (split str) (string-split str ":"))
>
>
> (define (parse-pat-str pat-str stx)
>
> (match (split pat-str)
>
> [(list pat-name-str type-str)
>
> (with-syntax ([type-pred (type-str->stx-type-pred type-str)]
>
> [pat-name (datum->syntax stx (string->symbol
>
> pat-name-str))])
>
> #'(? type-pred pat-name))]))
>
>
> (define (id:type? str)
>
> (and (string-contains? ":" str)
>
> (= 2 (length (split str)))
>
> (type-str->stx-type-pred (cadr (split str)))))
>
> )
>
>
> (define-match-expander :pat
>
> (lambda (stx)
>
> (define (rewrite pat)
>
> (cond [(identifier? pat) (let* ([pat-sym (syntax->datum pat)]
>
> [pat-str (symbol->string pat-sym)])
>
> (if (id:type? pat-str)
>
> (parse-pat-str pat-str stx)
>
> pat))]
>
> [(syntax->list pat) (datum->syntax pat (map rewrite (syntax->list
>
> pat)))]
>
> [(vector? (syntax-e pat)) (datum->syntax pat (vector-map rewrite
>
> (syntax-e pat)))]
>
> [else (print pat) (newline) (error "I don't know what to do.
>
> given:" pat)]))
>
> (syntax-case stx ()
>
> [(_ pat) (identifier? #'pat) (rewrite #'pat)]
>
> [(_ (pat ...))
>
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
>
> (syntax/loc stx (p ...)))]
>
> [(_ pat) #'pat])))
>
>
> (define-syntax (:match stx)
>
> (syntax-case stx ()
>
> [(:match val-expr [pat . more] ...)
>
> (with-syntax ([(new-pat ...) (for/list ([pat-stx (in-list (syntax->list
>
> #'(pat ...)))])
>
> (datum->syntax pat-stx `(:pat
>
> ,(syntax->datum pat-stx))))])
>
> #'(match val-expr [new-pat . more] ...))]))
>
>
>
> (check-equal? (:match 1 [n:num n]) 1)
>
> (check-equal? (:match 'x [n:num n] [_ 2]) 2)
>
>
> (check-equal? (:match "string" [s:str s]) "string")
>
> (check-equal? (:match 'x [s:str s] [_ 2]) 2)
>
>
> (check-equal? (:match (list 1 2 3) [l:lst l]) (list 1 2 3))
>
> (check-equal? (:match 'x [l:lst l] [_ 2]) 2)
>
>
> (check-equal? (:match (vector 1 2 3) [v:vec v]) (vector 1 2 3))
>
> (check-equal? (:match 'x [v:vec v] [_ 2]) 2)
>
>
> (check-equal? (:match #t [b:bool b]) #t)
>
> (check-equal? (:match #f [b:bool b]) #f)
>
> (check-equal? (:match 'x [b:bool b] [_ 2]) 2)
>
>
> (check-equal? (:match 'x [l l]) 'x)
>
>
> (check-equal? (:match '(2 x "foo" (3 4)) [(list n s f l) (list n s f l)])
>
> '(2 x "foo" (3 4)))
>
> (check-equal? (:match '(42 x) [(list n:num s:sym) (list n s)]) '(42 x))
>
>
> (check-equal? (:match '(1 2 #(1 2 3 (1 2 3 4)))
>
> [(list a:num b:num (vector a:num b:num c:num (list
>
> a:num b:num c:num d:num)))
>
> (list a b c d)])
>
> (list 1 2 3 4))
>
>
> (check-equal? (:match '(1 2 #(1 2 3 (1 2 3 4)))
>
> [`(,a:num ,b:num #(,a:num ,b:num ,c:num (,a:num ,b:num
>
> ,c:num ,d:num)))
>
> (list a b c d)])
>
> (list 1 2 3 4))
>
>
>
> On Dec 29, 2013, at 12:04 PM, Alexander D. Knauth wrote:
>
>
> I'm not really sure why this works either, but try this:
>
>
> (define-syntax (:match stx)
>
> (syntax-case stx ()
>
> [(:match val-expr [pat . more] ...)
>
> (with-syntax ([(new-pat ...) (for/list ([pat-stx (in-list (syntax->list
>
> #'(pat ...)))])
>
> (datum->syntax pat-stx `(:pat
>
> ,(syntax->datum pat-stx))))])
>
> #'(match val-expr [new-pat . more] ...))]))
>
>
> (check-equal? (:match '(42 x) [(list n:num s:sym) (list n s)])
>
> (match '(42 x) [(:pat (list n:num s:sym)) (list n s)]))
>
>
> On Dec 29, 2013, at 8:54 AM, Jens Axel Søgaard wrote:
>
>
> Hi Alexander,
>
>
> I extended your example to allow other patterns than symbols inside :pat.
>
>
> (match '(42 x) [(:pat (list n:num s:sym)) (list n s)])
>
>
> (list 42 x)
>
>
> This works fine. I now want to "hide" the :pat, that is I want to write:
>
>
> (:match '(42 x) [(list n:num s:sym) (list n s)])
>
>
> Since the syntax of match is: (match val-expr clause ...) and each clause
>
> has the form [pat . more] we can rewrite pat to [(:pat pat) . more].
>
>
> So I tried this:
>
>
> (define-syntax (:match stx)
>
> (syntax-case stx ()
>
> [(_ val-expr [pat . more] ...)
>
> #'(match val-expr [(:pat pat) . more] ...)]))
>
>
> This doesn't work however. I am tempted to consider this a bug in match,
>
> but I am not sure.
>
>
> #lang racket
>
> (require (for-syntax (only-in lang/htdp-intermediate-lambda
>
> string-contains?)
>
> racket/string
>
> racket/match)
>
> rackunit)
>
>
> (begin-for-syntax
>
> (define (type-str->stx-type-pred type-str)
>
> (match type-str
>
> ["num" #'number?]
>
> ["str" #'string?]
>
> ["sym" #'symbol?]
>
> ["lst" #'list?]
>
> [_ #f]))
>
>
> (define (split str) (string-split str ":"))
>
>
> (define (parse-pat-str pat-str stx)
>
> (match (split pat-str)
>
> [(list pat-name-str type-str)
>
> (with-syntax ([type-pred (type-str->stx-type-pred type-str)]
>
> [pat-name (datum->syntax stx (string->symbol
>
> pat-name-str))])
>
> #'(? type-pred pat-name))]))
>
>
> (define (id:type? str)
>
> (and (string-contains? ":" str)
>
> (type-str->stx-type-pred (cadr (split str))))))
>
>
> (define-match-expander :pat
>
> (lambda (stx)
>
> (define (rewrite pat)
>
> (let* ([pat-sym (syntax->datum pat)]
>
> [pat-str (symbol->string pat-sym)])
>
> (if (id:type? pat-str)
>
> (parse-pat-str pat-str stx)
>
> pat)))
>
> (syntax-case stx ()
>
> [(_ pat) (identifier? #'pat) (rewrite #'pat)]
>
> [(_ (pat ...))
>
> (with-syntax ([(p ...) (map rewrite (syntax->list #'(pat ...)))])
>
> (syntax/loc stx (p ...)))]
>
> [(_ pat) #'pat])))
>
>
> (define-syntax (:match stx)
>
> (syntax-case stx ()
>
> [(_ val-expr [pat . more] ...)
>
> #'(match val-expr [(:pat pat) . more] ...)]))
>
>
>
> (check-equal? (match 1 [(:pat n:num) n]) 1)
>
> (check-equal? (match 'x [(:pat n:num) n] [_ 2]) 2)
>
>
> (check-equal? (match "string" [(:pat s:str) s]) "string")
>
> (check-equal? (match 'x [(:pat s:str) s] [_ 2]) 2)
>
>
> (check-equal? (match (list 1 2 3) [(:pat l:lst) l]) (list 1 2 3))
>
> (check-equal? (match 'x [(:pat l:lst) l] [_ 2]) 2)
>
>
> (check-equal? (match 'x [(:pat l) l]) 'x)
>
>
> (check-equal? (match '(2 x "foo" (3 4)) [(:pat (list n s f l)) (list n
>
> s f l)]) '(2 x "foo" (3 4)))
>
> (check-equal? (match '(42 x) [(:pat (list n:num s:sym)) (list n s)]) '(42
>
> x))
>
>
>
> (match '(42 x) [(:pat (list n:num s:sym)) (list n s)])
>
> ; (:match '(42 x) [(list n:num s:sym) (list n s)])
>
>
>
>
> 2013/12/28 Alexander D.Knauth <alexander at knauth.org>:
>
>
> I just wrote a match-expander that does something like that:
>
>
>
> (check-equal? (match 1 [(my-pat n:num) n]) 1)
>
>
> (check-equal? (match 'x [(my-pat n:num) n] [_ 2]) 2)
>
>
>
> like this:
>
>
>
> #lang racket
>
>
>
> (require rackunit)
>
>
> (require (for-syntax
>
>
> (only-in lang/htdp-intermediate-lambda
>
>
> string-contains?)
>
>
> racket/string
>
>
> racket/match))
>
>
>
> (define-match-expander my-pat
>
>
> (lambda (stx)
>
>
> (syntax-case stx ()
>
>
> [(my-pat pat)
>
>
> (let* ([pat-sym (syntax->datum #'pat)]
>
>
> [pat-str (symbol->string pat-sym)])
>
>
> (cond [(not (string-contains? ":" pat-str))
>
>
> #'pat]
>
>
> [else
>
>
> (parse-pat-str pat-str stx)]))])))
>
>
>
> (define-for-syntax (parse-pat-str pat-str stx)
>
>
> (let ([split-pat (string-split pat-str ":")])
>
>
> (match split-pat
>
>
> [(list pat-name-str type-str)
>
>
> (with-syntax ([type-pred (type-str->stx-type-pred type-str)]
>
>
> [pat-name (datum->syntax stx (string->symbol
>
>
> pat-name-str))])
>
>
> #'(? type-pred pat-name))])))
>
>
>
> (define-for-syntax (type-str->stx-type-pred type-str)
>
>
> (match type-str
>
>
> ["num" #'number?]
>
>
> ["str" #'string?]
>
>
> ["lst" #'list?]))
>
>
>
> (check-equal? (match 1 [(my-pat n:num) n]) 1)
>
>
> (check-equal? (match 'x [(my-pat n:num) n] [_ 2]) 2)
>
>
>
> (check-equal? (match "string" [(my-pat s:str) s]) "string")
>
>
> (check-equal? (match 'x [(my-pat s:str) s] [_ 2]) 2)
>
>
>
> (check-equal? (match (list 1 2 3) [(my-pat l:lst) l]) (list 1 2 3))
>
>
> (check-equal? (match 'x [(my-pat l:lst) l] [_ 2]) 2)
>
>
>
>
>
> On Dec 26, 2013, at 2:45 PM, Jens Axel Søgaard wrote:
>
>
>
> The match pattern (? number? n) matches number and
>
>
> binds it to n.
>
>
>
> (match 1 [(? number? n) n])
>
>
>
> 1
>
>
>
> I'd like to write (match 1 [n:num n]) instead.
>
>
>
> Since there is no define-identifier-match-expander I have
>
>
> tried to make (match 1 [(n:num) n]) work. I need a hint.
>
>
>
> Here is a non-working attempt:
>
>
>
> (define-match-expander n:num
>
>
> (λ(stx)
>
>
> (syntax-case stx ()
>
>
> [(id)
>
>
> (with-syntax ([n (syntax/loc #'id n)])
>
>
> #'(? number? n))])))
>
>
>
>
> (check-equal? (match 1 [(n:num) n]) 1)
>
>
> (check-equal? (match 'x [(n:num) n] [_ 2]) 2)
>
>
>
> /Jens Axel
>
>
>
>
>
>
>
>
> --
>
>
> Jens Axel Søgaard
>
>
>
> ____________________
>
>
> Racket Users list:
>
>
> http://lists.racket-lang.org/users
>
>
>
>
>
>
>
> --
>
> --
>
> Jens Axel Søgaard
>
>
>
> ____________________
>
> Racket Users list:
>
> http://lists.racket-lang.org/users
>
>
>
>
>
>
> --
> --
> Jens Axel Søgaard
>
>
> ____________________
> Racket Users list:
> http://lists.racket-lang.org/users
>
>
--
--
Jens Axel Søgaard
![[logo]](/logo.png){kind=logo}