added when*

Macros/task-5.rkt

@@ -5,7 +5,6 @@
 
 ;; ---------------------------------------------------------------------------------------------------
 (require 7GUI/Macros/7guis 7GUI/Macros/7state)
-(define-syntax-rule (when=> (name exp) body ...) (let ((name exp)) (begin name body ...))) ;; -> base 
 
 ;; ---------------------------------------------------------------------------------------------------
 (define (selector! nu) (set! *prefix nu))

Macros/task-6.rkt

@@ -4,7 +4,7 @@
 ;; a circle drawer with undo/redo facilities (unclear spec for resizing)
 
 ;; ---------------------------------------------------------------------------------------------------
-(require 7GUI/Macros/7guis 7GUI/Macros/7state)
+(require 7GUI/Macros/7guis 7GUI/Macros/7state 7GUI/should-be-racket)
 
 ;; ---------------------------------------------------------------------------------------------------
 (define Default-Diameter 20)
@@ -89,8 +89,7 @@
           [(enter)      (set! *x 0)]
           [(left-down)  (when (is-empty-area *x *y) (add-circle! *x *y))]
           [(right-down)
-           (define on-circle (the-closest *x *y))
-           (when on-circle (lock) (popup-adjuster this on-circle))])))
+           (when* (the-closest *x *y) => (lambda (it) (lock) (popup-adjuster this it)))])))
 
     (define (paint-callback _self _evt)
       (cond
@@ -108,7 +107,7 @@
     (define dc (send this get-dc))))
 
 (define (popup-adjuster canvas closest-circle)
-  (define (cb _ evt)(when (eq? (send evt get-event-type) 'menu-popdown-none) (send canvas unlock)))
+  (define (cb _ evt) (when (eq? (send evt get-event-type) 'menu-popdown-none) (send canvas unlock)))
   (define pm (new popup-menu% [title "adjuster"][popdown-callback cb]))
   (new menu-item% [parent pm] [label "adjust radius"] [callback (adjuster! canvas closest-circle)])
   (send frame popup-menu pm  100 100))

Macros/task-7.rkt

@@ -3,6 +3,7 @@
 
 ;; a simple spreadsheet (will not check for circularities)
 
+(require 7GUI/should-be-racket)
 (require 7GUI/task-7-exp)
 (require 7GUI/task-7-view)
 (require 7GUI/canvas-double-click)
@@ -18,8 +19,7 @@
 (define (get-content ref*) (hash-ref *content ref* 0))
 
 (define (set-content! ref* vc)
-  (define current (get-content ref*))
-  (when (and current (not (= current vc)))
+  (when (and* (get-content ref*) (lambda (current) (not (= current vc))))
     (set! *content (values (hash-set *content ref* vc) ref*))))
 
 (define (propagate-content-change _ ref*)
@@ -56,10 +56,8 @@
          (text-field% [label #f] [min-width 200] [min-height 80] [init-value value0]
                       [callback (λ (self evt)
                                   (when (eq? (send evt get-event-type) 'text-field-enter)
-                                    (define valid (validator (send self get-value)))
-                                    (when valid 
-                                      (setter cell valid)
-                                      (send D show #f))))]))))
+                                    (when*  (validator (send self get-value))
+				      => (lambda (valid) (setter cell valid) (send D show #f)))))]))))
 
 (define content-edit (mk-edit "content for cell ~a" valid-content set-content! get-content))
 

Typed/sub-canvas.rkt

@@ -13,18 +13,18 @@
 ;; ---------------------------------------------------------------------------------------------------
 (require (for-syntax syntax/parse))
 (require (for-syntax racket/function))
+(require (for-syntax 7GUI/should-be-racket))
 
 ;; ---------------------------------------------------------------------------------------------------
 (define-syntax (define-type-canvas stx)
   (syntax-parse stx 
     [(_ name-of-type% (~optional (~seq #:minus-init (y:id ...))) extra ...)
      #:do [(define yy (map syntax-e (syntax->list #'(~? (y ...) ()))))
 
-           (define y-not-in-labels
-             (for*/first ((z yy) (yy (in-value z)) #:unless (memf (curry eq? yy) labels)) z))
-           (when y-not-in-labels
-             (define fmt (format "cannot subtract ~a from ~a" y-not-in-labels labels))
-             (raise-syntax-error 'define-type-canvas fmt))
+           (when* (for*/first ((z yy) (yy (in-value z)) #:unless (memf (curry eq? yy) labels)) z)
+	     => (lambda (y-not-in-labels)
+		  (define fmt (format "cannot subtract ~a from ~a" y-not-in-labels labels))
+		  (raise-syntax-error 'define-type-canvas fmt)))
 
            (define (in l) (memf (curry eq? l) yy))
            (define inits-included (for/list ([l labels][i inits] #:unless (in l)) i))]

Typed/task-5.rkt

@@ -41,8 +41,10 @@
 (def-cb (Update-cb {_b : Any}) (common-cb (λ ({x : Natural}) (update-entry (retrieve-name) x))))
 (def-cb (Delete-cb {_b : Any}) (common-cb delete-from))
 
+(require 7GUI/should-be-racket)
+
 (: common-cb (-> (-> Natural Void) Void))
-(define (common-cb f) (define i (send lbox get-selection)) (when i (f i)))
+(define (common-cb f) (when* (send lbox get-selection) => f))
 (: retrieve-name (-> String))
 (define (retrieve-name) (string-append (send surname get-value) ", " (send name get-value)))
 

Typed/task-7.rkt

@@ -6,6 +6,7 @@
 (require 7GUI/Typed/task-7-exp)
 (require 7GUI/Typed/task-7-view)
 (require 7GUI/Typed/canvas-double-click)
+(require 7GUI/should-be-racket)
 
 ;; ---------------------------------------------------------------------------------------------------
 (struct formula ({formula : Exp} {dependents : [Setof Ref]}) #:transparent)
@@ -28,8 +29,7 @@
   (define current (get-content ref*))
   (set! *content (hash-set *content ref* vc))
   (when (and current (not (= current vc)))
-    (define f (get-dependents ref*))
-    (when f (propagate-to f))))
+    (when* (get-dependents ref*) =>  propagate-to)))
 
 (: propagate-to (-> [Setof Ref] Void))
 (define (propagate-to dependents)
@@ -68,10 +68,8 @@
     (new text-field% [parent dialog] [label #f] [min-width 200] [min-height 80] [init-value value0]
          [callback (λ (self evt)
                      (when (eq? (send evt get-event-type) 'text-field-enter)
-                       (define valid (validator (send self get-value)))
-                       (when valid 
-                         (registration ref valid)
-                         (send dialog show #f))))])
+                       (when* (validator (send self get-value)) => 
+			 (lambda (valid) (registration ref valid) (send dialog show #f)))))])
     (send dialog show #t)))
 
 (define formula-fmt "a formula for cell ~a")

should-be-racket.rkt

@@ -0,0 +1,41 @@
+#lang racket
+
+(provide
+  =>
+ when*
+ unless*
+ and*)
+
+;; TODO make them more like the real thing  
+
+;; ---------------------------------------------------------------------------------------------------
+(require syntax/parse/define (for-syntax syntax/parse))
+(module+ test (require rackunit))
+
+;; ---------------------------------------------------------------------------------------------------
+(define-syntax => (lambda (stx) (raise-syntax-error '=> "used out of context")))
+
+(define-simple-macro
+  (when* condition:expr (~literal =>) body:expr)
+  (let ([it condition]) (when it (body it))))
+
+(define-simple-macro
+  (unless* condition:expr (~literal =>) body:expr)
+  (let ([it condition]) (unless it (body it))))
+
+(define-syntax (and* stx)
+  (syntax-parse stx
+    [(_) #'(and)]
+    [(_ e1:expr) #'(and e1)]
+    [(_ e1:expr (~literal =>) e-next:expr e2:expr ...)
+     #'(let ([it e1]) (and it (e-next it) (and* e2 ...)))]
+    [(_ e1:expr e2:expr ...) #'(and e1 (and* e2 ...))]))
+
+(module+ test
+  (check-equal? (when* (sin (/ pi 2)) => (λ (it) (- it 1.0))) 0.0) ;; ok ok
+  (check-equal? (unless* (sin (/ pi 2)) => (λ (it) (- it 1.0))) (void))
+
+  (check-true (and*))
+  (check-true (and* #t))
+  (check-true (and* (+ 1 1) => (λ (it) (> 3 it))))
+  (check-false (and* (+ 1 1) => (λ (it) (> 3 it)) #f)))

task-5.rkt

@@ -36,7 +36,8 @@
 (def-cb (Update-cb _b) (common-cb (curry update-entry (retrieve-name))))
 (def-cb (Delete-cb _b) (common-cb delete-from))
 
-(define (common-cb f) (define i (send lbox get-selection)) (when i (f i)))
+(require 7GUI/should-be-racket)
+(define (common-cb f) (when* (send lbox get-selection) => f))
 (define (retrieve-name) (string-append (send surname get-value) ", " (send name get-value)))
 
 ;; ---------------------------------------------------------------------------------------------------
@@ -54,4 +55,4 @@
 (new button% [label "Delete"][parent hpane2][callback Delete-cb])
 
 (prefix-cb "" '***)
-(send frame show #t)
+(send frame show #t)

task-7.rkt

@@ -19,12 +19,12 @@
 (define (get-dep ref*) (iff formula-dependents (hash-ref *formulas ref* #f) (set)))
 (define (get-content ref*) (hash-ref *content ref* 0))
 
+(require 7GUI/should-be-racket)
 (define (set-content! ref* vc)
   (define current (get-content ref*))
   (set! *content (hash-set *content ref* vc))
   (when (and current (not (= current vc)))
-    (define f (get-dep ref*))
-    (when f (propagate-to f))))
+    (when* (get-dep ref*) => propagate-to)))
 
 (define (propagate-to dependents)
   (for ((d (in-set dependents)))
@@ -57,10 +57,8 @@
     (new text-field% [parent dialog] [label #f] [min-width 200] [min-height 80] [init-value value0]
          [callback (λ (self evt)
                      (when (eq? (send evt get-event-type) 'text-field-enter)
-                       (define valid (validator (send self get-value)))
-                       (when valid 
-                         (registration cell valid)
-                         (send dialog show #f))))])
+                       (when* (validator (send self get-value))
+			 => (lambda (valid) (registration cell valid) (send dialog show #f)))))])
     (send dialog show #t)))
 
 (define content-edit (mk-edit "content for cell ~a" valid-content set-content! get-content))
@@ -74,4 +72,4 @@
 (send canvas init-auto-scrollbars WIDTH HEIGHT 0. 0.)
 (send canvas show-scrollbars #t #t)
 
-(send frame show #t)
+(send frame show #t)