[racket] define-match-expander

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

-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20131229/aa2a83fe/attachment-0001.html>