From d4763da563488159e37264b6442301dcc9d24cdb Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Fri, 12 Aug 2011 14:52:54 -0600
Subject: [PATCH] [honu] add structs and use . to lookup the field names in a
 struct instance

---
 collects/honu/core/main.rkt             |  1 +
 collects/honu/core/private/honu2.rkt    | 16 ++++++++----
 collects/honu/core/private/literals.rkt |  2 +-
 collects/honu/core/private/parse2.rkt   |  5 ++++
 collects/honu/core/private/struct.rkt   | 33 +++++++++++++++++++++++++
 5 files changed, 51 insertions(+), 6 deletions(-)
 create mode 100644 collects/honu/core/private/struct.rkt

diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt
index da786ede04..abd72ad0bf 100644
--- a/collects/honu/core/main.rkt
+++ b/collects/honu/core/main.rkt
@@ -21,6 +21,7 @@
                      [honu-cons ::]
                      [honu-and and]
                      [honu-or or]
+                     [honu-structure structure]
                      [literal:honu-= =]
                      [literal:semicolon |;|]
                      [literal:honu-comma |,|]
diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt
index 5478c483e1..c0a0188ddf 100644
--- a/collects/honu/core/private/honu2.rkt
+++ b/collects/honu/core/private/honu2.rkt
@@ -2,6 +2,7 @@
 
 (require "macro2.rkt"
          "operator.rkt"
+         "struct.rkt"
          (only-in "literals.rkt"
                   semicolon)
          (for-syntax syntax/parse
@@ -9,6 +10,7 @@
                      "parse2.rkt"
                      racket/base))
 
+(provide (all-from-out "struct.rkt"))
 
 (provide honu-function)
 (define-honu-syntax honu-function
@@ -91,13 +93,17 @@
   (lambda (left right)
     (with-syntax ([left left]
                   [right right])
-      #'(let ([left* left]
-              [right* right])
+      #'(let ([left* left])
+          (cond
+            [(honu-struct? left*) (let ([use (honu-struct-get left*)])
+                                    (use left* 'right))]
+            [else (error 'dot "don't know how to deal with ~a" 'left)]))
+      #;
+      #'(let ([left* left])
           (cond
-            #;
             [(list? left*)
-             (list-ref left* right*)]
-            [else (error 'dot "don't know how to deal with ~a and ~a" left* right*)])))))
+             (list-ref left* right)]
+            [else (error 'dot "don't know how to deal with ~a and ~a" 'left 'right)])))))
 
 (define-binary-operator honu-+ 1 'left +)
 (define-binary-operator honu-- 1 'left -)
diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt
index 01a0c2482d..966580b78d 100644
--- a/collects/honu/core/private/literals.rkt
+++ b/collects/honu/core/private/literals.rkt
@@ -25,4 +25,4 @@
                 honu-for-syntax
                 honu-for-template)
 
-(define-literal-set cruft (#%parens #%brackets #%braces semicolon honu-=))
+(define-literal-set cruft (#%parens #%brackets #%braces semicolon honu-= honu-comma))
diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt
index d45202dd53..524ef606aa 100644
--- a/collects/honu/core/private/parse2.rkt
+++ b/collects/honu/core/private/parse2.rkt
@@ -330,3 +330,8 @@
                    (parse stx))
     (debug "parsed ~a\n" parsed)
     (list (parsed-things stx unparsed) parsed)))
+
+(provide identifier-comma-list)
+(define-splicing-syntax-class identifier-comma-list
+                              #:literal-sets (cruft)
+  [pattern (~seq (~seq name:id (~optional honu-comma)) ...)]) 
diff --git a/collects/honu/core/private/struct.rkt b/collects/honu/core/private/struct.rkt
new file mode 100644
index 0000000000..46f8acf316
--- /dev/null
+++ b/collects/honu/core/private/struct.rkt
@@ -0,0 +1,33 @@
+#lang racket/base
+
+(require "macro2.rkt"
+         (for-syntax racket/base
+                     "parse2.rkt"
+                     "literals.rkt"
+                     syntax/parse
+                     unstable/syntax))
+
+(provide honu-struct honu-struct? honu-struct-get)
+(define-values (honu-struct honu-struct? honu-struct-get)
+               (make-struct-type-property 'honu-struct))
+
+(define-for-syntax (make-accessors name fields)
+  (for/list ([field fields])
+    (format-unique-id name "~a-~a" name field)))
+
+(provide honu-structure)
+(define-honu-syntax honu-structure
+  (lambda (code context)
+    (syntax-parse code #:literal-sets (cruft)
+      [(_ name:id (#%braces fields:identifier-comma-list) . rest)
+       (define out
+         (with-syntax ([(fields.name/accessor ...)
+                        (make-accessors #'name (syntax->list #'(fields.name ...)))])
+           #'(struct name (fields.name ...)
+                     #:property honu-struct (lambda (instance name)
+                                              (case name
+                                                [(fields.name) (fields.name/accessor instance)]
+                                                ...
+                                                [else (error 'dot "no such field name ~a" name)])))))
+       (values out #'rest #t)])))
+