commit bdf50d174e879185f97018222d5fb21c68deda33
parent 1a81a6de751b928b7b2444e2da06338e5473994b
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 8 Apr 2016 12:16:33 +0200
Implemented aif, awhen and acond.
Diffstat:
10 files changed, 228 insertions(+), 25 deletions(-)
diff --git a/README.md b/README.md
@@ -14,5 +14,5 @@ Anaphoric conditionnal forms for `racket`:
(acond
[(member 'a lst) (displayln it)]
[(member 'b lst) (displayln it)]
- [else (displayln "not found")] ;; Can't use "it" in the else clause.
+ [else (displayln "not found")]) ;; Can't use "it" in the else clause.
```
\ No newline at end of file
diff --git a/acond.rkt b/acond.rkt
@@ -0,0 +1,18 @@
+#lang racket
+
+(provide acond it)
+(require anaphoric/it
+ racket/stxparam)
+
+(define-syntax (acond stx)
+ (syntax-case stx (else)
+ [(_ [else . else-body])
+ #'(begin . else-body)]
+ [(_)
+ #'(void)]
+ [(_ [condition . body] . rest)
+ #'(let ([tmp condition])
+ (if tmp
+ (syntax-parameterize ([it (make-rename-transformer #'tmp)])
+ . body)
+ (acond . rest)))]))
+\ No newline at end of file
diff --git a/aif.rkt b/aif.rkt
@@ -0,0 +1,12 @@
+#lang racket
+
+(provide aif it)
+(require anaphoric/it
+ racket/stxparam)
+
+(define-syntax-rule (aif condition true-branch false-branch)
+ (let ([tmp condition])
+ (if tmp
+ (syntax-parameterize ([it (make-rename-transformer #'tmp)])
+ true-branch)
+ false-branch)))
+\ No newline at end of file
diff --git a/awhen.rkt b/awhen.rkt
@@ -0,0 +1,11 @@
+#lang racket
+
+(provide awhen it)
+(require anaphoric/it
+ racket/stxparam)
+
+(define-syntax-rule (awhen condition . body)
+ (let ([tmp condition])
+ (when tmp
+ (syntax-parameterize ([it (make-rename-transformer #'tmp)])
+ . body))))
+\ No newline at end of file
diff --git a/it.rkt b/it.rkt
@@ -0,0 +1,11 @@
+#lang racket
+
+(provide it)
+(require racket/stxparam)
+
+(define-syntax-parameter it
+ (λ (stx)
+ (raise-syntax-error
+ 'it
+ "Use of the \"it\" identifier is only allowd within anaphoric macros."
+ stx)))
+\ No newline at end of file
diff --git a/main.rkt b/main.rkt
@@ -1,8 +1,5 @@
#lang racket/base
-(module+ test
- (require rackunit))
-
;; Notice
;; To install (from within the package directory):
;; $ raco pkg install
@@ -12,24 +9,12 @@
;; $ raco pkg remove <<name>>
;; To view documentation:
;; $ raco docs <<name>>
-;;
-;; For your convenience, we have included a LICENSE.txt file, which links to
-;; the GNU Lesser General Public License.
-;; If you would prefer to use a different license, replace LICENSE.txt with the
-;; desired license.
-;;
-;; Some users like to add a `private/` directory, place auxiliary files there,
-;; and require them in `main.rkt`.
-;;
-;; See the current version of the racket style guide here:
-;; http://docs.racket-lang.org/style/index.html
-
-;; Code here
-
-(module+ test
- ;; Tests to be run with raco test
- )
-(module+ main
- ;; Main entry point, executed when run with the `racket` executable or DrRacket.
- )
+(provide (all-from-out anaphoric/it
+ anaphoric/aif
+ anaphoric/awhen
+ anaphoric/acond))
+(require anaphoric/it
+ anaphoric/aif
+ anaphoric/awhen
+ anaphoric/acond)
+\ No newline at end of file
diff --git a/scribblings/anaphoric.scrbl b/scribblings/anaphoric.scrbl
@@ -7,4 +7,42 @@
@defmodule[anaphoric]
-Package Description Here
+This package provides anaphoric versions of @racket[if],
+@racket[when] and @racket[cond]. These bind the syntax
+parameter @racket[if] to the value produced by the
+condition expression.
+
+@racketblock[(aif (member 'a lst)
+ (displayln it)
+ (displayln "not found"))]
+
+@racketblock[(awhen (member 'a lst)
+ (displayln it))]
+
+@racketblock[(acond
+ [(member 'a lst) (displayln it)]
+ [(member 'b lst) (displayln it)]
+ [else (displayln "not found")])]
+
+In the @racket[else] clause of @racket[acond] and in the
+else branch of @racket[aif], the @racket[it] syntax
+parameter keeps its value. This meeans it keeps the value
+bound by the surrounding conditionnal, if any. Otherwise it acts just
+like when it is used at the top-level, and raises a syntax error.
+
+@racketblock[(aif 'first
+ (aif (eq? 'second 'no)
+ 'not-executed
+ (displayln it))
+ 'not-executed)]
+
+In the example above, @racket[(displayln it)] prints
+@racket['first]. In the example below,
+@racket[(displayln it)] will raises a syntax error, as it
+appears in a sequence of else branches:
+
+@racketblock[(aif (eq? 'first 'no)
+ 'not-executed
+ (aif (eq? 'second 'no)
+ 'not-executed
+ (displayln it)))]
+\ No newline at end of file
diff --git a/test/acond-test.rkt b/test/acond-test.rkt
@@ -0,0 +1,79 @@
+#lang racket
+
+(require anaphoric/acond
+ rackunit)
+
+(define lst '(x y z a b c))
+(define seen 0)
+
+;; With else branch
+(check-equal? (acond
+ [(member 'a lst) (set! seen (add1 seen))
+ (check-equal? it '(a b c))
+ 'seen-01]
+ [(member 'b lst) (fail "acond selected wrong branch")]
+ [else (fail "acond selected wrong branch")])
+ 'seen-01)
+(check-equal? seen 1) ;; multiple body statements
+
+(check-equal? (acond
+ [(member 'absent lst) (fail "acond selected wrong branch")]
+ [(member 'b lst) (begin (check-equal? it '(b c))
+ 'seen-02)]
+ [else (fail "acond selected wrong branch")])
+ 'seen-02)
+
+(check-equal? (acond
+ [(member 'absent lst) (fail "acond selected wrong branch")]
+ [(member 'absent2 lst) (fail "acond selected wrong branch")]
+ [else 'seen-03])
+ 'seen-03)
+
+;; Just else branch
+(check-equal? (acond
+ [else 'seen-04])
+ 'seen-04)
+
+;; Multiple body statements
+
+(check-equal? (acond
+ [(member 'absent lst) (fail "acond selected wrong branch")]
+ [(member 'absent2 lst) (fail "acond selected wrong branch")]
+ [else (set! seen (add1 seen))
+ 'seen-05])
+ 'seen-05)
+(check-equal? seen 2)
+
+;; Without else branch
+(check-equal? (acond
+ [(member 'a lst) (set! seen (add1 seen))
+ (check-equal? it '(a b c))
+ 'seen-06]
+ [(member 'b lst) (fail "acond selected wrong branch")])
+ 'seen-06)
+(check-equal? seen 3)
+
+(check-equal? (acond
+ [(member 'absent lst) (fail "acond selected wrong branch")]
+ [(member 'b lst) (begin (check-equal? it '(b c))
+ 'seen-07)])
+ 'seen-07)
+
+(check-equal? (acond
+ [(member 'absent lst) (fail "acond selected wrong branch")]
+ [(member 'absent2 lst) (fail "acond selected wrong branch")])
+ (void))
+
+;; No branch
+(check-equal? (acond)
+ (void))
+
+;; Single branch
+(check-equal? (acond
+ [(member 'a lst) (begin (check-equal? it '(a b c))
+ 'seen-09)])
+ 'seen-09)
+
+(check-equal? (acond
+ [(member 'absent lst) (fail "acond selected wrong branch")])
+ (void))
+\ No newline at end of file
diff --git a/test/aif-test.rkt b/test/aif-test.rkt
@@ -0,0 +1,17 @@
+#lang racket
+
+(require anaphoric/aif
+ rackunit)
+
+(define lst '(x y z a b c))
+
+(check-equal? (aif (member 'a lst)
+ (begin (check-equal? it '(a b c))
+ 'seen)
+ (fail "aif selected wrong branch"))
+ 'seen)
+
+(check-equal? (aif (member 'absent lst)
+ (fail "aif selected wrong branch")
+ 'seen)
+ 'seen)
diff --git a/test/awhen-test.rkt b/test/awhen-test.rkt
@@ -0,0 +1,24 @@
+#lang racket
+
+(require anaphoric/awhen
+ rackunit)
+
+(define lst '(x y z a b c))
+(define seen 0)
+
+(check-equal? (awhen (member 'absent lst)
+ (fail "awhen should not have executed body")
+ 'seen)
+ (void))
+
+(check-equal? (awhen (member 'a lst)
+ 'seen)
+ 'seen)
+
+
+(check-equal? (awhen (member 'a lst)
+ (set! seen (add1 seen))
+ (check-equal? it '(a b c))
+ 'seen)
+ 'seen)
+(check-equal? seen 1) ;; Multiple body statements
+\ No newline at end of file
