From 6e3c509a86c6ee7706e272a6c55930ee95bbfb3f Mon Sep 17 00:00:00 2001
From: Ben Greenman <benjaminlgreenman@gmail.com>
Date: Mon, 5 Jun 2017 20:21:32 -0400
Subject: [PATCH] require-typed: more informative error when struct field is
 missing

add a typed-field syntax class (`[id : expr]`) and use it to report errors + simplify other code
---
 .../typed-racket/base-env/prims-contract.rkt     | 16 ++++++++++++----
 .../fail/require-typed-struct-missing-colon.rkt  | 13 +++++++++++++
 2 files changed, 25 insertions(+), 4 deletions(-)
 create mode 100644 typed-racket-test/fail/require-typed-struct-missing-colon.rkt

diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt
index 605489a3..0d176cb4 100644
--- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt
+++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt
@@ -111,6 +111,10 @@
   (pattern nm:id #:with parent #'#f)
   (pattern (nm:id parent:id)))
 
+(define-syntax-class typed-field
+  #:attributes (field type)
+  #:literals (:)
+  (pattern [field:id : type]))
 
 (define-values (require/typed-legacy require/typed -unsafe-require/typed)
  (let ()
@@ -142,7 +146,7 @@
     #:attributes (nm type (body 1) (constructor-parts 1) (tvar 1))
     (pattern [(~or (~datum struct) #:struct)
               (~optional (~seq (tvar ...)) #:defaults ([(tvar 1) '()]))
-              nm:opt-parent (body ...)
+              nm:opt-parent (body:typed-field ...)
               (~var opts (struct-opts legacy #'nm.nm))]
              #:with (constructor-parts ...) #'opts.ctor-value
              #:attr type #'opts.type))
@@ -150,7 +154,9 @@
   (define-syntax-class signature-clause
     #:literals (:)
     #:attributes (sig-name [var 1] [type 1])
-    (pattern [#:signature sig-name:id ([var:id : type] ...)]))
+    (pattern [#:signature sig-name:id (body:typed-field ...)]
+      #:with (var ...) #'(body.field ...)
+      #:with (type ...) #'(body.type ...)))
 
   (define-syntax-class opaque-clause
     ;#:literals (opaque)
@@ -450,7 +456,7 @@
     (syntax-parse stx #:literals (:)
       [(_ name:opt-parent
           (~optional (~seq (tvar:id ...)) #:defaults ([(tvar 1) '()]))
-          ([fld : ty] ...)
+          (body:typed-field ...)
           (~var input-maker (constructor-term legacy #'name.nm))
           (~optional (~seq #:type-name type:id) #:defaults ([type #'name.nm]))
           unsafe:unsafe-clause
@@ -460,6 +466,8 @@
                       [hidden (generate-temporary #'name.nm)]
                       [orig-struct-info (generate-temporary #'nm)]
                       [spec (if (syntax-e #'name.parent) #'(nm parent) #'nm)]
+                      [(fld ...) #'(body.field ...)]
+                      [(ty ...) #'(body.type ...)]
                       [num-fields (syntax-length #'(fld ...))]
                       [(type-des _ pred sel ...)
                        (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
@@ -540,7 +548,7 @@
                                   (make-struct-info-self-ctor #'internal-maker si)
                                   si))
 
-                         (dtsi* (tvar ...) spec type ([fld : ty] ...) #:maker maker-name #:type-only)
+                         (dtsi* (tvar ...) spec type (body ...) #:maker maker-name #:type-only)
                          #,(ignore #'(require/contract pred hidden (or/c struct-predicate-procedure?/c (c-> any-wrap/c boolean?)) lib))
                          #,(internal #'(require/typed-internal hidden (Any -> Boolean : type)))
                          (require/typed #:internal (maker-name real-maker) type lib
diff --git a/typed-racket-test/fail/require-typed-struct-missing-colon.rkt b/typed-racket-test/fail/require-typed-struct-missing-colon.rkt
new file mode 100644
index 00000000..5ede43eb
--- /dev/null
+++ b/typed-racket-test/fail/require-typed-struct-missing-colon.rkt
@@ -0,0 +1,13 @@
+#;
+(exn-pred ".*while parsing typed-field.*")
+#lang racket/base
+
+(module server racket
+  (provide (struct-out posn))
+  (struct posn [x y]))
+
+(module client typed/racket
+  (require/typed (submod ".." server)
+    (#:struct posn ((x Integer) (y Integer)))))
+
+(require 'client)