From 832d1ed9cfc2b30456c363bd6f44365d579c41bb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Wed, 20 Jan 2016 20:36:04 +0100
Subject: [PATCH] Added typed version of stx-cons.

---
 graph-lib/lib/low.rkt | 48 ++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 45 insertions(+), 3 deletions(-)

diff --git a/graph-lib/lib/low.rkt b/graph-lib/lib/low.rkt
index 53f17561..7baff5e9 100644
--- a/graph-lib/lib/low.rkt
+++ b/graph-lib/lib/low.rkt
@@ -1017,18 +1017,60 @@
 
 (module m-stx-untyped racket
   (require syntax/stx)
-  (provide stx-cons stx-drop-last)
+  (provide stx-cons #;stx-drop-last)
   
   ;(: stx-cons (∀ (A B) (→ A B (Syntaxof (Pairof A B)))))
   (define (stx-cons a b) #`(#,a . #,b))
   
   ;(: stx-drop-last (∀ (A) (→ (Syntaxof (Listof A)) (Syntaxof (Listof A)))))
-  (define (stx-drop-last l)
+  #;(define (stx-drop-last l)
     (if (and (stx-pair? l) (stx-pair? (stx-cdr l)))
         (stx-cons (stx-car l) (stx-drop-last (stx-cdr l)))
         #'())))
 
-(require 'm-stx-untyped)
+;; stx-cons
+
+(module m-stx-typed typed/racket
+  (require typed/racket/unsafe)
+  (unsafe-require/typed (submod ".." m-stx-untyped)
+                        [stx-cons (∀ (A B)
+                                     (→ (Syntaxof A)
+                                        (Syntaxof B)
+                                        (Syntaxof (Pairof (Syntaxof A)
+                                                          (Syntaxof B)))))])
+  (provide stx-cons))
+
+(module+ test
+  (require ;(submod "..")
+           typed/rackunit)
+  
+  (check-equal? (syntax->datum
+                 (ann (stx-cons #'a #'(b c))
+                      (Syntaxof (Pairof (Syntaxof 'a)
+                                        (Syntaxof (List (Syntaxof 'b)
+                                                        (Syntaxof 'c)))))))
+                '(a b c))
+  
+  (check-equal? (syntax->datum
+                 (ann (stx-cons #'1 (ann #'2 (Syntaxof 2)))
+                      (Syntaxof (Pairof (Syntaxof 1)
+                                        (Syntaxof 2)))))
+                '(1 . 2)))
+
+(require/provide 'm-stx-typed)
+
+;; stx-pair?
+
+(: stx-pair? (→ Any Boolean : (Syntaxof Any)))
+(define (stx-pair? x) (if (syntax? x) #t #f))
+
+;; stx-drop-last
+
+(: stx-drop-last (∀ (A) (→ (Syntaxof (Listof A)) (Syntaxof (Listof A)))))
+(define (stx-drop-last l)
+  (if (and (stx-pair? l) (stx-pair? (stx-cdr l)))
+      (stx-cons (stx-car l) (stx-drop-last (stx-cdr l)))
+      #'()))
 
 ; (require/typed racket/base [(assoc assoc3)
 ;                             (∀ (a b) (→ Any (Listof (Pairof a b))