[def] common-lisp inspired 'def' macro

like define, but optionally accepts
- contracts
- pre/post conditions
- docstring
- tests

def/def-test.rkt

@@ -0,0 +1,55 @@
+#lang racket/base
+
+;; NOTE: every `#:test` clause expands to a `module+ test`
+
+(require syntax-parse-example/def/def)
+
+(module+ test
+  (require (only-in rackunit check-exn)))
+
+(def (plus1 (x : integer?))
+  "Add 1 to the given integer"
+  #:test [
+    ((plus1 1) ==> 2)
+    ((plus1 2) ==> 3)]
+  (+ x 1))
+
+(module+ test
+  (check-exn #rx"plus1: contract violation.*expected: integer?"
+    (λ () (plus1 'a))))
+
+(def (times3 y)
+  "Multiply given number by 3"
+  #:test [
+    ((times3 3) ==> 9) ]
+  (+ y y y))
+
+(def (gcd (x : integer?) (y : integer?))
+  "greatest common divisor"
+  #:pre [
+    (>= "First argument must be greater-or-equal than second")]
+  #:test [
+    ((gcd 10 3) ==> 1)
+    ((gcd 12 3) ==> 3)]
+  (cond
+   [(zero? y) x]
+   [else (gcd y (- x (* y (quotient x y))))]))
+
+(module+ test
+  (check-exn #rx"must be greater"
+    (λ () (gcd 1 4))))
+
+(def (zardoz x)
+  "Return 42"
+  #:test [
+    ((zardoz 0) ==> 42)
+    ((zardoz "asdf") ==> 42)]
+  #:post [
+    ((λ (r) (equal? r 42)) "should always return 42")]
+  42)
+
+(def (hello)
+  "prints 'hello'"
+  #:test [
+    ((hello) ==> (void) #:stdout "hello\n")]
+  (printf "hello\n"))

def/def.rkt

@@ -0,0 +1,69 @@
+#lang racket/base
+(provide def)
+(require rackunit (for-syntax racket/base syntax/parse))
+
+(begin-for-syntax
+  (define-syntax-class arg-spec
+    #:attributes (name type)
+    #:datum-literals (:)
+    (pattern
+      (name:id : type:expr))
+    (pattern
+     name:id
+     #:with type #'#f))
+
+  (define-syntax-class doc-spec
+    (pattern
+      e:str))
+)
+
+(define-syntax (def stx)
+  (syntax-parse stx #:datum-literals (==>)
+   [(_ (name:id arg*:arg-spec ...)
+      (~or ;; using (~or (~once a) ...) to simulate an unordered (~seq a ...)
+        (~once (~describe #:role "docstring" "docstring" doc:doc-spec))
+        (~once (~seq #:test ((in* ==> out*
+                             (~optional (~seq #:stdout expected-output*:str)
+                                        #:defaults ([expected-output* #'#f])))
+                            ...)))
+        (~once (~optional (~seq #:pre ([check-pre* pre-doc*:doc-spec] ...))
+                          #:defaults ([(check-pre* 1) '()] [(pre-doc* 1) '()])))
+        (~once (~optional (~seq #:post ([check-post* post-doc*:doc-spec] ...))
+                          #:defaults ([(check-post* 1) '()] [(post-doc* 1) '()])))) ...
+       body)
+    #:with check-types
+      #'(for ([arg-name (in-list (list arg*.name ...))]
+              [arg-type (in-list (list arg*.type ...))]
+              [i        (in-naturals)]
+              #:when arg-type)
+          (unless (arg-type arg-name)
+            (raise-argument-error 'name (symbol->string (object-name arg-type)) i arg-name)))
+    #:with check-pre
+      #'(for ([pre-check (in-list (list check-pre* ...))]
+              [pre-doc   (in-list (list pre-doc* ...))])
+          (unless (pre-check arg*.name ...)
+            (raise-user-error 'name pre-doc)))
+    #:with check-post
+      #'(lambda (result)
+          (for ([post-check (in-list (list check-post* ...))]
+                [post-doc   (in-list (list post-doc* ...))])
+            (unless (post-check result)
+              (error 'name post-doc))))
+    #:with test-cases
+      #'(module+ test
+          (let* ([p (open-output-string)]
+                 [result-val (parameterize ([current-output-port p]) in*)]
+                 [result-str (begin0 (get-output-string p)
+                                     (close-output-port p))])
+              (check-equal? result-val out*)
+              (when expected-output*
+                (check-equal? result-str expected-output*)))
+          ...)
+    #'(begin
+        test-cases
+        (define (name arg*.name ...)
+          check-types
+          check-pre
+          (let ([result body])
+            (begin0 result
+                    (check-post result)))))]))

def/def.scrbl

@@ -0,0 +1,112 @@
+#lang syntax-parse-example
+@require[
+  (for-label racket/base syntax/parse syntax-parse-example/def/def)]
+
+@(define def-eval
+   (make-base-eval '(require syntax-parse-example/def/def)))
+
+@title{@tt{def}}
+
+@; =============================================================================
+
+@examples[#:eval def-eval
+ (module snoc racket/base
+   (require syntax-parse-example/def/def)
+   (def (snoc (x* : list?) x)
+     "Append the value `x` to the end of the given list"
+     #:test [
+       ((snoc '(1 2) 3) ==> '(1 2 3))
+       ((snoc '(a b) '(c)) ==> '(a b (c)))]
+     (append x* (list x)))
+   (provide snoc))
+ (require 'snoc)
+ (eval:error (snoc 1 '(2 3)))
+ (snoc '(1 2) 3)
+]
+
+The @racket[def] macro is similar to @racket[define] but:
+@itemlist[
+@item{
+  requires a docstring
+}
+@item{
+  requires test cases;
+}
+@item{
+  optionally accepts contract annotations on its arguments; and
+}
+@item{
+  optionally accepts pre- and post- conditions.
+}
+]
+
+@examples[#:eval def-eval
+  (module gcd racket/base
+    (require syntax-parse-example/def/def)
+    (def (gcd (x : integer?) (y : integer?))
+      "greatest common divisor"
+      #:pre [
+        (>= "First argument must be greater-or-equal than second")]
+      #:test [
+        ((gcd 10 3) ==> 1)
+        ((gcd 12 3) ==> 3)]
+      (cond
+       [(zero? y) x]
+       [else (gcd y (- x (* y (quotient x y))))]))
+     (provide gcd))
+  (require 'gcd)
+  (eval:error (gcd 42 777))
+  (gcd 777 42)
+]
+
+If the docstring or test cases are missing, @racket[def] throws a syntax error.
+
+@examples[#:eval def-eval
+  (eval:error (def (f x)
+                x))
+  (eval:error (def (f x)
+                "identity"
+                x))
+  (eval:error (def (f x)
+                #:test [((f 1) ==> 1)]
+                x))
+]
+
+How to read the macro:
+@itemlist[#:style 'ordered
+@item{
+  The @racket[begin-for-syntax] defines two syntax classes (see @secref["Syntax_Classes" #:doc '(lib "syntax/scribblings/syntax.scrbl")]).
+  The first syntax class, @racket[arg-spec], captures arguments with an optional contract annotation.
+  The second, @racket[doc-spec], captures docstrings.
+}
+@item{
+  The large @racket[~or] pattern captures the required-and-optional stuff that
+   @racket[def] accepts---in particular, the docstring, the @racket[#:test] test cases,
+   the @racket[#:pre] pre-conditions, and the @racket[#:post] post-conditions.
+}
+@item{
+  The four @racket[#:with] clauses build syntax objects that run unit tests
+   and/or checks.
+}
+]
+
+The @racket[def] macro:
+
+@racketfile{def.rkt}
+
+Notes:
+@itemlist[
+@item{
+  This macro gives poor error messages when the docstring or test
+   cases are missing.
+}
+@item{
+  The @racket[doc-spec] syntax class could be extended to accept Scribble, or
+   another kind of docstring syntax.
+}
+@item{
+  A @racket[#:test] case may optionally use the @racket[#:stdout] keyword.
+  If given, the test will fail unless running the test prints the same string
+   to @racket[current-output-port].
+}
+]

index.scrbl

@@ -19,3 +19,4 @@
 @include-example{first-class-or}
 @include-example{cross-macro-communication}
 @include-example{let-star}
+@include-example{def}