From 2477fe9f4b5d726c482ac956d8f2b26f3035785d Mon Sep 17 00:00:00 2001
From: "William J. Bowman" <wjb@williamjbowman.com>
Date: Thu, 24 Sep 2015 18:01:42 -0400
Subject: [PATCH] Made case macro do more work

Now the case macro is closer to a pattern-matcher.
---
 scribblings/stdlib/sugar.scrbl |  4 ++--
 stdlib/bool.rkt                | 11 ++++-------
 stdlib/nat.rkt                 |  7 ++++---
 stdlib/sugar.rkt               | 23 +++++++++++++----------
 4 files changed, 23 insertions(+), 22 deletions(-)

diff --git a/scribblings/stdlib/sugar.scrbl b/scribblings/stdlib/sugar.scrbl
index 4c97775..55eb301 100644
--- a/scribblings/stdlib/sugar.scrbl
+++ b/scribblings/stdlib/sugar.scrbl
@@ -83,7 +83,7 @@ defining curried functions via @racket[lambda*].
 Like @racket[define], but uses @racket[forall*] instead of @racket[lambda*].
 }
 
-@defform[(case* D e P [pattern maybe-IH body] ...)
+@defform[(case* e [pattern maybe-IH body] ...)
          #:grammar
          [(pattern
             constructor
@@ -98,7 +98,7 @@ defined.
 
 @examples[#:eval curnel-eval
           (require cur/stdlib/nat)
-          (case* Nat z (lambda (x : Nat) Bool)
+          (case z
             [z true]
             [(s (n : Nat))
              IH: ((_ : Bool))
diff --git a/stdlib/bool.rkt b/stdlib/bool.rkt
index 7e2c810..d0709a7 100644
--- a/stdlib/bool.rkt
+++ b/stdlib/bool.rkt
@@ -6,13 +6,10 @@
   (true : Bool)
   (false : Bool))
 
-(define-syntax (if syn)
-  (syntax-case syn ()
-    [(_ t s f)
-     ;; Compute the motive
-     (let ([M #`(lambda (x : #,(type-infer/syn #'t))
-                  #,(type-infer/syn #'s))])
-       (quasisyntax/loc syn (elim Bool t #,M s f)))]))
+(define-syntax-rule (if t s f)
+  (case t
+    [true s]
+    [false f]))
 
 (define (not (x : Bool)) (if x false true))
 
diff --git a/stdlib/nat.rkt b/stdlib/nat.rkt
index d5df010..044166e 100644
--- a/stdlib/nat.rkt
+++ b/stdlib/nat.rkt
@@ -15,16 +15,17 @@
   (check-equal? (add1 (s z)) (s (s z))))
 
 (define (sub1 (n : Nat))
-  (case* Nat n (lambda (x : Nat) Nat)
+  (case n
     [z z]
     [(s (x : Nat)) IH: ((ih-n : Nat)) x]))
 (module+ test
   (check-equal? (sub1 (s z)) z))
 
 (define (plus (n1 : Nat) (n2 : Nat))
-  (case* Nat n1 (lambda (x : Nat) Nat)
+  (case n1
     [z n2]
-    [(s (x : Nat)) IH: ((ih-n1 : Nat))
+    [(s (x : Nat))
+     IH: ((ih-n1 : Nat))
      (s ih-n1)]))
 (module+ test
   (check-equal? (plus z z) z)
diff --git a/stdlib/sugar.rkt b/stdlib/sugar.rkt
index 9391f48..cd0d35b 100644
--- a/stdlib/sugar.rkt
+++ b/stdlib/sugar.rkt
@@ -6,12 +6,8 @@
   lambda*
   #%app
   define
-  case*
-  define-type
-  define-theorem
-  qed
-  real-app
-  define-rec)
+  case
+  define-type)
 
 (require
   (only-in "../cur.rkt"
@@ -79,10 +75,17 @@
 
 ;; TODO: Expects clauses in same order as constructors as specified when
 ;; TODO: inductive D is defined.
-(define-syntax (case* syn)
-  (syntax-case syn ()
-    [(_ D e P clause* ...)
-     #`(elim D e P #,@(map rewrite-clause (syntax->list #'(clause* ...))))]))
+(define-syntax (case syn)
+  ;; duplicated code
+  (define (clause-body syn)
+    (syntax-case (car (syntax->list syn)) (: IH:)
+      [((con (a : A) ...) IH: ((x : t) ...) body) #'body]
+      [(e body) #'body]))
+  (syntax-case syn (=>)
+    [(_ e clause* ...)
+     (let* ([D (type-infer/syn #'e)]
+            [M (type-infer/syn (clause-body #'(clause* ...)))])
+       #`(elim #,D e (lambda (x : #,D) #,M) #,@(map rewrite-clause (syntax->list #'(clause* ...)))))]))
 
 (define-syntax-rule (define-theorem name prop)
   (define name prop))