From b82dec5599a0869f92fcc44f635c78e299897e48 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 1 Mar 2016 14:18:59 +0100
Subject: [PATCH] Fixes GH issue #315 Syntax properties are not forwarded by
 `define-typed/untyped-identifier`, following @samth's suggestions.

---
 typed-racket-more/typed/untyped-utils.rkt     | 15 +---
 ...d-untyped-identifier-syntax-properties.rkt | 83 +++++++++++++++++++
 2 files changed, 86 insertions(+), 12 deletions(-)
 create mode 100644 typed-racket-test/succeed/define-typed-untyped-identifier-syntax-properties.rkt

diff --git a/typed-racket-more/typed/untyped-utils.rkt b/typed-racket-more/typed/untyped-utils.rkt
index 89505c27..baab35b5 100644
--- a/typed-racket-more/typed/untyped-utils.rkt
+++ b/typed-racket-more/typed/untyped-utils.rkt
@@ -4,7 +4,8 @@
                      syntax/parse
                      syntax/stx
                      racket/syntax
-                     typed-racket/utils/tc-utils)
+                     typed-racket/utils/tc-utils
+                     typed-racket/typecheck/renamer)
          typed-racket/utils/tc-utils)
 
 (provide syntax-local-typed-context?
@@ -14,22 +15,12 @@
 (define (syntax-local-typed-context?)
   (unbox typed-context?))
 
-(define-for-syntax (rename-head stx id)
-  (syntax-case stx ()
-    [(_ . args)  (quasisyntax/loc stx (#,id . args))]
-    [_  (quasisyntax/loc stx #,id)]))
-
-(define-for-syntax ((typed/untyped-renamer typed-name untyped-name) stx)
-  (if (unbox typed-context?)
-      (rename-head stx typed-name)
-      (rename-head stx untyped-name)))
-
 (define-syntax (define-typed/untyped-identifier stx)
   (syntax-parse stx
     [(_ name:id typed-name:id untyped-name:id)
      (syntax/loc stx
        (define-syntax name
-         (typed/untyped-renamer #'typed-name #'untyped-name)))]))
+         (make-typed-renaming #'typed-name #'untyped-name)))]))
 
 (define-for-syntax (freshen ids)
   (stx-map (lambda (id) ((make-syntax-introducer) id)) ids))
diff --git a/typed-racket-test/succeed/define-typed-untyped-identifier-syntax-properties.rkt b/typed-racket-test/succeed/define-typed-untyped-identifier-syntax-properties.rkt
new file mode 100644
index 00000000..f530a563
--- /dev/null
+++ b/typed-racket-test/succeed/define-typed-untyped-identifier-syntax-properties.rkt
@@ -0,0 +1,83 @@
+#lang racket
+
+;; https://github.com/racket/typed-racket/issues/315
+
+(module t/u racket
+  (provide typed/untyped
+           (rename-out [typed/untyped-typed original-typed-req-stx]
+                       [typed/untyped-untyped original-untyped-req-stx]))
+  
+  (require typed/untyped-utils
+           racket/require-syntax
+           (for-syntax syntax/strip-context))
+  
+  (define-require-syntax (typed/untyped-typed stx)
+    (displayln 'typed)
+    (syntax-case stx ()
+      [(_ m s) (replace-context stx #'(submod m s typed))]))
+  
+  (define-require-syntax (typed/untyped-untyped stx)
+    (displayln 'untyped)
+    (syntax-case stx ()
+      [(_ m s) (replace-context stx #'(submod m s untyped))]))
+  
+  (define-typed/untyped-identifier typed/untyped
+    typed/untyped-typed
+    typed/untyped-untyped))
+
+(module m racket
+  (module typed typed/racket
+    (provide test-value typed-test-value)
+    (define test-value : Symbol 'is-typed)
+    (define typed-test-value : Symbol 'present))
+  (module untyped typed/racket/no-check
+    (provide test-value untyped-test-value)
+    (define test-value : Symbol 'is-untyped)
+    (define untyped-test-value : Symbol 'present)))
+
+(module test-typed-1 typed/racket
+  (require (submod ".." t/u))
+  (require typed/rackunit)
+  (require (original-typed-req-stx ".." m))
+  (check-equal? test-value 'is-typed)
+  (check-equal? typed-test-value 'present))
+
+(module test-typed-2 typed/racket
+  (require (submod ".." t/u))
+  (require typed/rackunit)
+  (require (typed/untyped ".." m))
+  (check-equal? test-value 'is-typed)
+  (check-equal? typed-test-value 'present))
+
+(module test-typed-3 typed/racket
+  (require (submod ".." t/u))
+  (require typed/rackunit)
+  (define-syntax renamer (make-rename-transformer #'original-typed-req-stx))
+  (require (renamer ".." m))
+  (check-equal? test-value 'is-typed)
+  (check-equal? typed-test-value 'present))
+
+(module test-untyped-1 racket
+  (require (submod ".." t/u))
+  (require rackunit)
+  (require (original-untyped-req-stx ".." m))
+  (check-equal? test-value 'is-untyped)
+  (check-equal? untyped-test-value 'present))
+
+(module test-untyped-2 racket
+  (require (submod ".." t/u))
+  (require rackunit)
+  (require (typed/untyped ".." m))
+  (check-equal? test-value 'is-untyped)
+  (check-equal? untyped-test-value 'present))
+
+(module test-untyped-3 racket
+  (require (submod ".." t/u))
+  (require rackunit)
+  (define-syntax renamer (make-rename-transformer #'original-untyped-req-stx))
+  (require (renamer ".." m))
+  (check-equal? test-value 'is-untyped)
+  (check-equal? untyped-test-value 'present))
+
+(require 'test-typed-1 'test-typed-2 'test-typed-3
+         'test-untyped-1 'test-untyped-2 'test-untyped-3)
\ No newline at end of file