From 44c6c951cc0d1e4ba8ea23d83372189fe8c42202 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Thu, 22 Oct 2015 18:17:38 +0200
Subject: [PATCH] Added lib/sequences.rkt, transformed format-ids into a
 function, moved format-ids and the rest of lib/untyped/ids.rkt into
 lib/low.rkt, added define-modules macro. Adjusted README and lib/untyped.rkt
 accordingly.

---
 graph/README              |   7 +-
 graph/lib/low.rkt         | 155 ++++++++++++++++++++++++++++++++++++++
 graph/lib/sequences.rkt   |  45 +++++++++++
 graph/lib/untyped.rkt     |   3 +-
 graph/lib/untyped/ids.rkt | 114 ----------------------------
 5 files changed, 202 insertions(+), 122 deletions(-)
 create mode 100644 graph/lib/sequences.rkt
 delete mode 100644 graph/lib/untyped/ids.rkt

diff --git a/graph/README b/graph/README
index c4e91719..945b6d02 100644
--- a/graph/README
+++ b/graph/README
@@ -203,10 +203,6 @@ Library functions and utilities
   
   Wrapper around lib/low.rkt that allows using it from a untyped racket file.
 
-* lib/untyped/ids.rkt
-  
-  Some untyped racket utilities to manipulate identifiers inside macros.
-
 * lib/untyped/for-star-list-star.rkt
 
   A utility macro similar to for*/list to iterate over collections and return a
@@ -214,8 +210,7 @@ Library functions and utilities
 
 * lib/untyped.rkt
 
-  Aggregates lib/low-untyped.rkt, lib/untyped/ids.rkt and
-  lib/untyped/for-star-list-star.rkt.
+  Aggregates lib/low-untyped.rkt, and lib/untyped/for-star-list-star.rkt.
 
 * lib/test-framework.rkt
   
diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt
index 503d9c32..cbf95464 100644
--- a/graph/lib/low.rkt
+++ b/graph/lib/low.rkt
@@ -4,6 +4,30 @@
 (: degub (∀ (T) (→ T T)))
 (define (degub x) (display "degub:") (displayln x) x)
 
+;; ==== low/typed-untyped-module.rkt ====
+
+(define-syntax define-modules
+  (syntax-rules (no-submodule)
+    [(_ ([no-submodule] [name lang] ...) . body)
+     (begin (begin . body)
+            (module name lang . body) ...)]
+    [(_ ([name lang] ...) . body)
+     (begin (module name lang . body) ...)]))
+
+#|
+;; TODO: tests: test with a macro and check that we can use it in untyped.
+;; TODO: tests: test with two mini-languages with different semantics for some
+;; function.
+(define-modules ([foo typed/racket] [foo-untyped typed/racket/no-check])
+  (provide x)
+  (: x (→ Syntax Syntax))
+  (define (x s) s))
+
+(module test racket
+  (require (submod ".." foo-untyped))
+  (x #'a))
+|#
+
 ;; ==== low/require-provide.rkt ====
 (provide require/provide)
 
@@ -179,6 +203,11 @@
                                                          (syntax-e b)
                                                          (syntax-e a))])
                 '(3 2 1))
+  
+  (check-equal? (match #'(1 2 3)
+                  [(stx-list a ...) (map (inst syntax-e Positive-Byte) a)])
+                '(1 2 3))
+  
   #;(check-equal? (match #`(1 . (2 3)) [(stx-list a b c) (list (syntax-e c)
                                                                (syntax-e b)
                                                                (syntax-e a))])
@@ -342,3 +371,129 @@
          (rename-out [match-lambda match-λ]
                      [match-lambda* match-λ*]
                      [match-lambda** match-λ**]))
+
+
+;; ==== ids.rkt ====
+
+(define-modules ([no-submodule] [ids-untyped typed/racket/no-check])
+  (provide format-ids
+           hyphen-ids
+           format-temp-ids
+           #|t/gen-temp|#)
+  
+  (require/typed racket/syntax
+                 [format-id (→ Syntax String (U String Identifier) * Identifier)])
+  ;(require racket/sequence) ;; in-syntax
+  
+  (require "sequences.rkt"
+           #|"../low.rkt"|#) ;; my-in-syntax
+  
+  (define-type S-Id-List
+    (U String
+       Identifier
+       (Listof String)
+       (Listof Identifier)
+       (Syntaxof (Listof Identifier))))
+  
+  (: format-ids (→ (U Syntax (→ (U String Identifier) * Syntax))
+                   String
+                   S-Id-List *
+                   (Listof Identifier)))
+  (define (format-ids lex-ctx format . vs)
+    (let* ([seqs
+            (map (λ ([v : S-Id-List])
+                   (cond
+                     [(string? v) (in-cycle (in-value v))]
+                     [(identifier? v) (in-cycle (in-value v))]
+                     [(list? v) (in-list v)]
+                     [else (in-list (syntax->list v))]))
+                 vs)]
+           [justconstants (andmap (λ (x) (or (string? x) (identifier? x))) vs)]
+           [seqlst (apply sequence-list seqs)])
+      (for/list : (Listof Identifier)
+        ([items seqlst]
+         [bound-length (if justconstants
+                           (in-value 'yes)
+                           (in-cycle (in-value 'no)))])
+        
+        (apply format-id
+               (if (procedure? lex-ctx) (apply lex-ctx items) lex-ctx)
+               format
+               items))))
+  
+  (: hyphen-ids (→ (U Syntax (→ (U String Identifier) * Syntax))
+                   S-Id-List *
+                   (Listof Identifier)))
+  
+  (define (hyphen-ids lex-ctx . vs)
+    (apply format-ids
+           lex-ctx
+           (string-join (map (λ _ "~a") vs) "-")
+           vs))
+  
+  (: format-temp-ids (→ String
+                        S-Id-List *
+                        (Listof Identifier)))
+  
+  (define (format-temp-ids format . vs)
+    ;; Introduce the binding in a fresh scope.
+    (apply format-ids (λ _ ((make-syntax-introducer) #'())) format vs)))
+
+(module+ test
+  (require ;(submod "..")
+    ;"test-framework.rkt"
+    (for-syntax racket/syntax
+                (submod ".." ids-untyped)))
+  
+  (check-equal? (format-ids #'a "~a-~a" #'() #'())
+                '())
+  
+  (check-equal? (map syntax->datum
+                     (format-ids #'a "~a-~a" #'(x1 x2 x3) #'(a b c)))
+                '(x1-a x2-b x3-c))
+  
+  ;; Since the presence of "Syntax" in the parameters list makes format-ids
+  ;; require a chaperone contract instead of a flat contract, we can't run the
+  ;; two tests below directly, we would need to require the untyped version of
+  ;; this file, which causes a cycle in loading.
+  
+  (define-syntax (test1 stx)
+    (syntax-case stx ()
+      [(_ (let1 d1) x y)
+       (begin
+         (define/with-syntax (foo-x foo-y)
+           (format-ids (λ (xy)
+                         (if (string=? (symbol->string (syntax->datum xy))
+                                       "b")
+                             stx
+                             #'()))
+                       "foo-~a"
+                       #'(x y)))
+         #'(let1 d1 (let ((foo-b 2) (foo-c 'b)) (cons foo-x foo-y))))]))
+  
+  (check-equal? (test1 (let ((foo-b 1) (foo-c 'a))) b c)
+                '(1 . b))
+  
+  (define-syntax (fubar stx)
+    (define/with-syntax (v1 ...) #'(1 2 3))
+    (define/with-syntax (v2 ...) #'('a 'b 'c))
+    ;; the resulting ab and ab should be distinct identifiers:
+    (define/with-syntax (id1 ...) (format-temp-ids "~a" #'(ab cd ab)))
+    (define/with-syntax (id2 ...) (format-temp-ids "~a" #'(ab cd ab)))
+    #'(let ([id1 v1] ...)
+        (let ([id2 v2] ...)
+          (list (cons id1 id2) ...))))
+  
+  (check-equal? (fubar) '((1 . a) (2 . b) (3 . c))))
+
+#|
+(define-template-metafunction (t/gen-temp stx)
+  (syntax-parse stx
+    [(_ . id:id)
+     #:with (temp) (generate-temporaries #'(id))
+     #'temp]
+    [(_ id:id ...)
+     (generate-temporaries #'(id ...))]))
+|#
+
+;; ==== end ====
\ No newline at end of file
diff --git a/graph/lib/sequences.rkt b/graph/lib/sequences.rkt
new file mode 100644
index 00000000..a382011b
--- /dev/null
+++ b/graph/lib/sequences.rkt
@@ -0,0 +1,45 @@
+#lang typed/racket
+
+(provide sequence-cons sequence-null sequence-list)
+
+(: sequence-cons (∀ (A B) (→ (Sequenceof A) (Sequenceof B)
+                             (Sequenceof (cons A B)))))
+(define (sequence-cons sa sb)
+  (sequence-map (λ ([x : (List A B)]) (cons (car x) (cadr x)))
+                (in-values-sequence (in-parallel sa sb))))
+
+(: sequence-null (Sequenceof Null))
+(define sequence-null (in-cycle (in-value '())))
+
+;; sequence-list should have the type:
+;; (∀ (A ...) (→ (Sequenceof A) ... (Sequenceof (List A ...)))))
+;; But the type system rejects the two definitions below.
+(: sequence-list (∀ (A) (→ (Sequenceof A) *
+                           (Sequenceof (Listof A)))))
+(define (sequence-list . sequences)
+  (if (null? sequences)
+      sequence-null
+      (sequence-cons (car sequences) (apply sequence-list (cdr sequences)))))
+
+#|
+(: sequence-list (∀ (A ...) (→ (Sequenceof A) ...
+                               (Sequenceof (List A ...)))))
+(define (sequence-list . sequences)
+  (if (null? sequences)
+      sequence-null
+      (sequence-cons (car sequences) (apply sequence-list (cdr sequences)))))
+|#
+
+#|
+(: sequence-list (∀ (F R ...)
+                    (case→ [→ (Sequenceof Null)]
+                           [→ (Sequenceof F) (Sequenceof R) ...
+                              (Sequenceof (List F R ...))])))
+(define sequence-list
+  (case-lambda
+    [()
+     sequence-null]
+    [(sequence . sequences)
+     (sequence-cons sequence (apply sequence-list sequences))]))
+|#
+
diff --git a/graph/lib/untyped.rkt b/graph/lib/untyped.rkt
index a894c58f..cfa38bdc 100644
--- a/graph/lib/untyped.rkt
+++ b/graph/lib/untyped.rkt
@@ -1,5 +1,4 @@
 #lang typed/racket
 
 (require "low-untyped.rkt")
-(require/provide "untyped/for-star-list-star.rkt"
-                 "untyped/ids.rkt")
\ No newline at end of file
+(require/provide "untyped/for-star-list-star.rkt")
diff --git a/graph/lib/untyped/ids.rkt b/graph/lib/untyped/ids.rkt
deleted file mode 100644
index 4f628484..00000000
--- a/graph/lib/untyped/ids.rkt
+++ /dev/null
@@ -1,114 +0,0 @@
-#lang racket
-
-(provide format-ids
-         hyphen-ids
-         format-temp-ids
-         #|t/gen-temp|#)
-
-(require racket/syntax) ;; Used to bind format-id in macroexpansion below.
-(require racket/sequence) ;; Used to bind in-syntax in macroexpansion below.
-;; Used to bind in-syntax on older versions in macroexpansion below:
-;(require unstable/sequence)
-(require (for-syntax racket/syntax
-                     syntax/parse
-                     racket/string
-                     racket/sequence
-                     ;unstable/sequence ;; in-syntax on older versions
-                     #|syntax/parse/experimental/template|#)
-         syntax/strip-context)
-
-;; Actually, this could be just a regular function:
-;; test (with list?, syntax? and combinations thereof) if we should iterate or
-;; just put the value as-is.
-(begin-for-syntax
-  (define-syntax-class var-expr
-    #:description
-    (string-append "#'identifier or #'(identifier ooo), where ooo is a"
-                   " literal “...”, or #'(identifier ...), or an expression")
-    (pattern (~and whole ((~literal syntax) var:id))
-             #:with code #'(in-value whole))
-    (pattern (~and whole ((~literal syntax) (var:id (~literal ...))))
-             #:with code #'(in-syntax whole))
-    (pattern (~and whole ((~literal syntax) (vars:id ...)))
-             #:with (var . _) #`(vars ... #,(gensym 'empty))
-             #:with code #'(in-syntax whole))
-    (pattern expr:expr
-             #:with var (gensym)
-             #:with code #'(let ((s expr)) (if (string? s) (in-value s) s)))))
-
-;; TODO: infinite loop if we only have constants which ar handled with for-value
-(define-syntax (format-ids stx)
-  (syntax-parse stx
-    [(_ lexical-context:expr format:expr v:var-expr ...)
-     (define/with-syntax (tmp ...) (generate-temporaries #'(v.var ...)))
-     #'(let ([lex-ctx lexical-context])
-         (for/list ([tmp v.code] ...)
-           (format-id (if (procedure? lex-ctx) (lex-ctx tmp ...) lex-ctx)
-                      format
-                      tmp ...)))]))
-
-(define-syntax (hyphen-ids stx)
-  (syntax-parse stx
-    ;; TODO: allow single #'foo instead of (var expr), and use in-value
-    [(_ lexical-context:expr v:var-expr ...)
-     #`(format-ids lexical-context
-                   #,(string-join (for/list ([x (in-syntax #'(v ...))])  "~a")
-                                  "-")
-                   v ...)]))
-
-(define-syntax (format-temp-ids stx)
-  (syntax-parse stx
-    [(_ . rest)
-     ;; Introduce the binding in a fresh scope.
-     #'(format-ids (λ _ ((make-syntax-introducer) #'())) . rest)]))
-
-#|
-(define-template-metafunction (t/gen-temp stx)
-  (syntax-parse stx
-    [(_ . id:id)
-     #:with (temp) (generate-temporaries #'(id))
-     #'temp]
-    [(_ id:id ...)
-     (generate-temporaries #'(id ...))]))
-|#
-
-(module* test racket
-  (require (submod "..")
-           rackunit
-           (for-syntax racket/syntax
-                       (submod "..")))
-  
-  (check-equal? (format-ids #'a "~a-~a" #'() #'())
-                '())
-  (check-equal? (map syntax->datum
-                     (format-ids #'a "~a-~a" #'(x1 x2 x3) #'(a b c)))
-                '(x1-a x2-b x3-c))
-  
-  (define-syntax (test1 stx)
-    (syntax-case stx ()
-      [(_ (let1 d1) x y)
-       (begin
-         (define/with-syntax (foo-x foo-y)
-           (format-ids (λ (xy)
-                         (if (string=? (symbol->string (syntax->datum xy))
-                                       "b")
-                             stx
-                             #'()))
-                       "foo-~a"
-                       #'(x y)))
-         #'(let1 d1 (let ((foo-b 2) (foo-c 'b)) (cons foo-x foo-y))))]))
-
-  (check-equal? (test1 (let ((foo-b 1) (foo-c 'a))) b c)
-                '(1 . b))
-  
-  (define-syntax (fubar stx)
-    (define/with-syntax (v1 ...) #'(1 2 3))
-    (define/with-syntax (v2 ...) #'('a 'b 'c))
-    ;; the resulting ab and ab should be distinct identifiers:
-    (define/with-syntax (id1 ...) (format-temp-ids "~a" #'(ab cd ab)))
-    (define/with-syntax (id2 ...) (format-temp-ids "~a" #'(ab cd ab)))
-    #'(let ([id1 v1] ...)
-        (let ([id2 v2] ...)
-          (list (cons id1 id2) ...))))
-  
-  (check-equal? (fubar) '((1 . a) (2 . b) (3 . c))))