Decorators in racket

Show & Tell
6

Hi, @luistung.

This is really cool; definitely one of my favourite bits of Python syntax. I cut my teeth on higher-order functions with the old snake.

This is kind of a hacky attempt which doesn't really enforce any constraints on the positioning of the decorators, and it is slightly less general perhaps in its approach to the decorator functions themselves, but I'm sure others will have brighter ideas regarding a more "Racket-ey" version of things.

#lang racket/base

(require
  racket/stxparam
  (for-syntax
   racket/base
   racket/syntax
   syntax/parse
   syntax/parse/lib/function-header))

(define-for-syntax none (gensym))
(define-syntax (define-syntax-parameter/parameter stx)
  (syntax-case stx ()
    [(_ name init)
     (with-syntax ([param (format-id stx "the-~a" #'name #:subs? #true)]
                   [fresh (format-id stx   "a-~a" #'name #:subs? #true)])
       #'(begin
           (define-syntax-parameter name (make-parameter init))
           (begin-for-syntax
             (define (param [ex none])
               (define param (syntax-parameter-value #'name))
               (if (eq? none ex) {param} {param ex}))
             (define (fresh [ex init]) (make-parameter ex)))))]))

(define-syntax-parameter/parameter stack #false)

(begin-for-syntax
  (define (no-stack-error)
    (raise-syntax-error
     'decorator "the decorator stack has not been created"))
  
  (define (on-stack-error)
    (raise-syntax-error
     'decorator "the decorator stack has not been cleared"
     (map syntax->datum {the-stack})))
  
  (define (undecorated?) (null? {the-stack}))
  
  (define (push fun)
    {the-stack (cons fun {the-stack})})
  
  (define (pull fun)
    (define decor {the-stack})
    ({the-stack #false}
     . and . #`(compose #,@decor #,fun))))

(define-syntax (@ stx)
  (syntax-case stx ()
    [[_ #:decorate]
     (when   {the-stack} (on-stack-error))
     ({the-stack null} . and . #'(void))]
    
    [[_ fun]
     (unless {the-stack} (no-stack-error))
     ((push #'fun) . and . #'(void fun))]))

(define-syntax (define@ stx)
  (syntax-parse stx
    [(_ head:function-header . body)
     
     #:fail-when (undecorated?)
     "expected at least one decorator, found none"

     #:with wrap #'(syntax-parameterize ([stack (a-stack)]) . body)
     #`(define head.name
         (let () (define head wrap) #,(pull #'head.name)))]))

(define ((couch type) room)
  (hash-set room 'couch type))

(define ((curtains type) room)
  (hash-set room 'curtains type))

(define ((rug type) room)
  (hash-set room 'rug type))

[@ #:decorate]
[@ (couch "leather")]
[@ (curtains "all the flowers")]
[@ (rug "faded persian")]
(define@ (living-room)
  (hasheq 'room "living-room"))

(living-room)
;=> '#hasheq((couch . "leather")
;            (curtains . "all the flowers")
;            (room . "living-room")
;            (rug . "faded persian"))

(define (square x) (* x x))
(define (double x) (* 2 x))
(define (triple x) (* 3 x))

[@ #:decorate]
[@ triple]
[@ square]
(define@ (number-1) 1)

(number-1)
;=> 9

[@ #:decorate]
[@ square]
[@ triple]
(define@ (number-2) 2)

(number-2)
;=> 12

(define ((pre/post pre post) fun)
  (pre) (fun) (post))

[@ #:decorate]
[@ (pre/post
    (lambda _ (println "pre"))
    (lambda _ (println "post")))]
(define@ ((test say))
  (println say))

(test "middle")
;=> "pre"
;=> "middle"
;=> "post"

[@ #:decorate]
[@ square]
[@ double]
(define@ (number-3)
  [@ #:decorate]
  [@ triple]
  (define@ (three) 1)
  
  [@ #:decorate]
  [@ double]
  (define@ (two) 1)
  
  (* (three) (two)))

(number-3)
;=> 72

(define ((fork n) x) (apply values (build-list n (λ _ x))))

[@ #:decorate]
[@ (fork 2)] [@ list]
[@ (fork 3)] [@ list]
[@ (fork 4)] [@ list]
(define@ (spread) null)

(spread)
;=> '(((() ()) (() ()) (() ()))
;     ((() ()) (() ()) (() ()))
;     ((() ()) (() ()) (() ()))
;     ((() ()) (() ()) (() ())))

Thanks for sharing--great for tinkering on a Saturday :racket_heart:

Edit: just cleaned up the messiness a bit.

2 Likes