View patterns in Racket

views.rkt

#lang racket/base

(require (rename-in racket/match)
         (for-syntax racket/base))

(define-match-expander zero
  (λ (stx) #'0)
  (λ (stx) #'0))

(define-match-expander succ
  (λ (stx)
    (syntax-case stx () 
      [(succ n) #'(and (app sub1 n)
                       (? (λ (x) (> x 0))))]))
  (λ (stx)
    (syntax-case stx ()
      [(succ n) #'(add1 n)])))

(define (fib n)
  (match n
    [(zero) zero]
    [(succ (zero)) (succ zero)]
    [(succ (succ n)) (+ (fib n)
                        (fib (succ n)))]))

(define-match-expander even
  (λ (stx)
    (syntax-case stx ()
      [(even n) #'(and (app (λ (n) (/ n 2)) n)
                       (? (λ (n) (> n 0)))
                       (? (λ (n) (= (modulo n 2) 0))))]))

  (λ (stx)
    (syntax-case stx ()
      [(even n)
       #'(when (> (* 2 n) 0)
           (* 2 n))])))

(define (uncons xs)
  (match xs
    [(list xs ... x) (cons x xs)]))

; TODO: recursive match-expanders (a la Wadler)
(define-match-expander snoc
  (syntax-rules ()
    [(_ xs x) (app inits `(,xs . ,x))]))

(define-match-expander snocer
  (syntax-rules ()
    [(_ xs x) (app uncons `(,x . ,xs))]))

(define (sum xs)
  (match xs
    ['() 0]
    [(cons x xs) (+ x (sum xs))]))

(define-match-expander weird
  (λ (stx)
    (syntax-case stx ()
      [(_ x)
       (let ([v (syntax->datum #'x)])
         (if (< v 0) 
             (void) 
             #'(weird  )))])))