#lang racket

(require (for-syntax syntax/parse))

;; Macros created with define-syntax are functions from syntax objects to syntax
;; objects. Syntax objects are basically s-expressions + a bunch of binding
;; information and metadata.

;; GRAMMAR: (when-let ([id condition-expr] ...) body ...)
;; Executes body forms if every condition-expr is non-false, and binds the
;; result of each condition-expr to the corresponding id in the body forms.
(define-syntax (when-let stx)

  ;; syntax-parse is a DSL that accepts a syntax object and a list of pattern +
  ;; expression pairs, grammar is (syntax-parse stx-expr [pattern expr] ...). It
  ;; performs a pattern match on the syntax object and evaluates the expression
  ;; for the matching pattern.

  (syntax-parse stx

    ;; Syntax patterns are s-expressions but can include "syntax classes" on
    ;; parts of the expression, written using colons. For example this pattern:
    ;;
    ;;   (foo:id bar:str any)
    ;;
    ;; ...matches this s-expression:
    ;;
    ;;   (some-id "lorem ipsum" (any (random (s-exp) here)))
    ;;
    ;; These are some of the syntax classes included by default in syntax/parse:
    ;;
    ;;   id - matches an identifier
    ;;   str - matches a literal string
    ;;   expr - matches any s-expression other than a keyword(*)
    ;;
    ;; (*) - Keywords are kind of like symbols, but they #:look #:like #:this.

    [(when-let ([id:id condition-expr:expr] ...) body ...)

     ;; Matched subexpressions are bound as "pattern variables" that can
     ;; be used in a (syntax (...)) form to substitute the matched code.
     (syntax
      (let ([id condition-expr] ...)
        (when (and id ...) body ...)))]))


;; Assume find-user and find-widget look up a user/widget ID in a database and
;; return either a user/widget data structure if the row exists, or false if the
;; ID doesn't match any rows

(define (find-user _) #f)
(define (find-widget _) #f)
(define check-user-widget-permissions void)
(define frobnicate-user void)

(when-let ([user (find-user "bob@aol.com")]
           [widget (find-widget "eW91cmVhY3VyaW91c2ZlbGxvd2FyZW50eW91")])
  ;; This code only runs if both user and widget are not false
  (check-user-widget-permissions user widget)
  (frobnicate-user user widget))

;@------------------------------------------------------------------------------
;; PART 2 - SYNTAX CLASSES

;; Now lets define some syntax classes to abstract over some common structures
;; that show up a lot in different macros, and to make when-let handle duplicate
;; identifiers correctly by raising an error.

;; Syntax classes are used in macros at compile time. So we have to define them
;; at compile time by wrapping them in a (begin-for-syntax ...) block.
(begin-for-syntax

  ;; A syntax class matching a single [id expr] binding pair.
  (define-syntax-class binding

    ;; A syntax class's description text is used when generating error messages.
    ;; It also serves as lightweight in-source documentation.

    #:description "binding pair"

    ;; A syntax class can have attributes, which let you reference sub-parts of
    ;; what the class matches. For example, a pattern like pair:binding matched
    ;; against the syntax [user (find-user "bob@aol.com")] would make the
    ;; following pattern variables available in a (syntax ...) form:
    ;;
    ;;   pair - [user (find-user "bob@aol.com")] (the whole binding pair)
    ;;   pair.var - user (just the variable name)
    ;;   pair.rhs - user (the right-hand-side (RHS) expression)

    #:attributes [var rhs]

    ;; A (pattern _) form uses the same pattern syntax that syntax-parse uses.
    ;; Matched variables are used for the syntax class's attributes. Failing to
    ;; use a variable for every attribute causes a compile error when the syntax
    ;; class is defined.
    (pattern [var:id rhs:expr]))

  ;; A syntax class matching a series of binding pairs ([id expr] ...) where no
  ;; two identifiers can be the same.
  (define-syntax-class distinct-bindings
    #:description "sequence of unique binding pairs"

    ;; The 1 part means "with one level of ellipses", because this class binds
    ;; multiple pairs, variables, and right-hand-side expressions instead of
    ;; only one. Users of this syntax class must use each attribute with the
    ;; correct number of ellipses.

    #:attributes [(pair 1) (var 1) (rhs 1)]

    (pattern (pair:binding ...)
             ;; The #:with clause binds more attributes in addition to whatever
             ;; was bound by the pattern. Grammar: #:with pattern expr
             #:with (var ...) (syntax (pair.var ...))
             #:with (rhs ...) (syntax (pair.rhs ...))

             ;; The #:fail-when clause evaluates an expression when the syntax
             ;; class is used and, if it is not false, fails the pattern match.
             ;; The expression can return a syntax object instead of just
             ;; returning true; if it does that syntax object is combined with
             ;; the message string in the error message created by the failed
             ;; pattern match.
             #:fail-when (check-duplicate-identifier
                          (syntax->list (syntax (var ...))))
             "duplicate variable name")))

;; Now we can write a more robust when-let macro using our reusable syntax
;; classes.

(define-syntax (when-let2 stx)
  (syntax-parse stx
    [(when-let2 bindings:distinct-bindings body ...)
     (syntax
      (let bindings
        (when (and bindings.var ...)
          body ...)))]))

;; The previous usage example works the same as before

(when-let2 ([user (find-user "bob@aol.com")]
            [widget (find-widget "eW91cmVhY3VyaW91c2ZlbGxvd2FyZW50eW91")])
  (check-user-widget-permissions user widget)
  (frobnicate-user user widget))

;; But this example raises a compile error. It's commented out for now; to
;; uncomment it and see the compile error, delete the #; characters prefixing
;; the expression. If you're using DrRacket, notice that the compile error
;; highlights the second "user" identifier in red when it's raised.

#;(when-let2 ([user (find-user "bob@aol.com")]
            [user (find-user "alice@aol.com")]
            [widget (find-widget "eW91cmVhY3VyaW91c2ZlbGxvd2FyZW50eW91")])
  (check-user-widget-permissions user widget)
  (frobnicate-user user widget))

;; Error message text:
;;
;; when-let2: duplicate variable name
;;  parsing context:
;;   while parsing sequence of unique binding pairs in: user
;;
;; The message also points to the second "user" identifier via highlighting in
;; DrRacket or via a file path with line and column numbers in the terminal
;; console (if this module is compiled from the command line).