racket macro

macro.rkt

#lang racket

(define-syntax foo
  (lambda (stx)
    (syntax "I am foo")))

(define-syntax (also-foo stx)
  (syntax "I am also foo"))

(define-syntax (quated-foo stx)
  #'"I am also #'foo")

(define-syntax (say-hi stx)
  #'(displayln "hi"))

(define-syntax (show-me stx)
  (print stx)
  #'(void))

(define stx #'(if x (list "true") #f))

(define-syntax (reverse-me stx)
  (datum->syntax stx (reverse (cdr (syntax->datum stx)))))

(define-syntax (foo-ng stx)
  (make-pipe)
  #'(void))

(define-syntax (our-if stx)
  (define xs (syntax->list stx))
  (datum->syntax stx
                 `(cond [,(cadr xs) ,(caddr xs)]
                        [else ,(cadddr xs)])))

(require (for-syntax racket/match))     ; required racket/base at compile time
(define-syntax (our-if-using-match stx)
  (match (syntax->list stx)
    [(list name condition true-expr false-expr)
     (datum->syntax stx `(cond [,condition ,true-expr]
                               [else ,false-expr]))]))

(define-syntax (our-if-using-syntax-case stx)
  (syntax-case stx ()
    [(_ condition true-expr false-expr)
     #'(cond [condition true-expr]
             [else false-expr])]))

(define-syntax-rule (our-if-using-syntax-rule condition true-expr false-expr)
  (cond [condition true-expr]
        [else false-expr]))

(define-syntax (hyphen-define stx)
  (syntax-case stx ()
    [(_ a b (args ...) body0 body ...)
     (syntax-case
         (datum->syntax #'a (string->symbol (format "~a-~a"
                                                    (syntax->datum #'a)
                                                    (syntax->datum #'b))))
         ()
       [name #'(define (name args ...)
                 body0
                 body ...)])]))

(define-syntax (hyphen-define-with-syntax stx)
  (syntax-case stx ()
    [(_ a b (args ...) body0 body ...)
     (with-syntax ([name (datum->syntax #'a
                                        (string->symbol (format "~a-~a" (syntax->datum #'a) (syntax->datum #'b))))])
       #'(define (name args ...)
           body0 body ...))]))

;;  error
(define-syntax-rule (hyphen-define-with-syntax-rule a b (args ...) body0 body ...)
  (with-syntax ([name (datum->syntax #'a
                                     (string->symbol
                                      (format "~a-~a" (syntax->datum #'a) (syntax->datum #'b))))])
    (define (name args ...)
      body0 body ...)))

(require (for-syntax racket/syntax))
(define-syntax (foo-using-with-syntax* stx)
  (syntax-case stx ()
    [(_ a) (with-syntax* ([b #'a]
                          [c #'b])
             #'c)]))

(define-syntax (hypen-define-using-format-id stx)
  (syntax-case stx ()
    [(_ a b (args ...) body0 body ...)
     (with-syntax ([name (format-id #'a "~a-~a" #'a #'b)])
       #'(define (name args ...)
           body0 body ...))]))

(define-syntax (hyphen-define* stx)
  (syntax-case stx ()
    [(_ (names ...) (args ...) body0 body ...)
     (let ([names-stxs (syntax->list #'(names ...))])
       (with-syntax ([name (datum->syntax (car names-stxs)
                                          (string->symbol
                                           (string-join (for/list ([name-stx names-stxs])
                                                          (symbol->string
                                                           (syntax-e name-stx))
                                                          ) "-")))])
         #'(define (name args ...) body0 body ...)))]))

(module+ test
  (require rackunit)
  (test-equal? "syntax transformer" (foo) "I am foo")
  (test-equal? "abbrev define-syntax" (also-foo) "I am also foo")
  (test-equal? "syntax shorthand #' " (quated-foo) "I am also #'foo")
  (test-equal? "more than string" (with-output-to-string (thunk (say-hi))) "hi\n")
  (test-equal? "print syntax object" (show-me '(+ 1 2)) (void))

  (test-equal? "syntax source" (syntax-source stx) (syntax-source #'1))
  (test-equal? "syntax line" (syntax-line stx) 20)
  (test-equal? "syntax column" (syntax-column stx) 14)
  (test-equal? "syntax datum" (syntax->datum stx) '(if x (list "true") #f))
  (for ((s (syntax-e stx))
        (t (list #'if #'x #'(list "true") #'#f)))
    (test-equal? "syntax e" (syntax->datum s) (syntax->datum t)))
  (test-equal? "syntax->list" (syntax->list stx) (syntax-e stx))

  (test-equal? "reverse-me" (reverse-me 1 2 3 list) '(3 2 1))
  (test-equal? "our-if true" (our-if #t 1 2) 1)
  (test-equal? "our-if false" (our-if #f 1 2) 2)
  (test-equal? "our-if-using-match true" (our-if #t 1 2) 1)
  (test-equal? "our-if-using-match false" (our-if #f 1 2) 2)
  (test-equal? "our-if-using-syntax-case" (our-if-using-match #t 1 2) (our-if-using-syntax-case #t 1 2))
  (test-equal? "our-if-using-syntax-rule" (our-if-using-match #f 1 2) (our-if-using-syntax-rule #f 1 2))

  (hyphen-define foo bar () #t)
  (test-equal? "hyphen define" (foo-bar) #t)

  ;; error
  ;; (hyphen-define-with-syntax-rule foo bar2 (a) a)
  ;; (test-equal? "hyphen define with syntax rule" (foo-bar2 3) 3)

  (test-equal? "using with syntax*" (foo-using-with-syntax* 3) 3)
  (hypen-define-using-format-id foo bar3 (a) a)
  (test-equal? "using format-id" (foo-bar3 3) 3)
  (println 'OK)
  )