From 7d639f43627e0606a3378c992d8674d5a7406a73 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Sun, 9 Apr 2017 15:09:42 +0200
Subject: [PATCH] =?UTF-8?q?Renamed=20dotlambda/lang=20=E2=86=92=20dotlambd?=
 =?UTF-8?q?a?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 implementation.rkt | 190 ++++++++++++++++++++++++++++++++++++++++++++
 lang.rkt           |   6 --
 main.rkt           | 192 +--------------------------------------------
 3 files changed, 194 insertions(+), 194 deletions(-)
 create mode 100644 implementation.rkt
 delete mode 100644 lang.rkt

diff --git a/implementation.rkt b/implementation.rkt
new file mode 100644
index 0000000..82e643e
--- /dev/null
+++ b/implementation.rkt
@@ -0,0 +1,190 @@
+#lang racket
+(provide #%dotted-id
+         #%dot-separator
+         (rename-out [new-#%module-begin #%module-begin]))
+
+(require typed/racket)
+  
+(require (submod phc-toolkit untyped)
+         racket/stxparam
+         (for-syntax racket/string
+                     racket/list
+                     syntax/parse
+                     racket/syntax
+                     syntax/strip-context
+                     racket/struct
+                     racket/function
+                     syntax/srcloc
+                     phc-toolkit/stx/fold
+                     (only-in racket/base [... …])))
+
+(define-for-syntax identifier→string (compose symbol->string syntax-e))
+
+(define-syntax (#%dot-separator stx)
+  (raise-syntax-error '#%dot-separator
+                      "Can only be used in special contexts"
+                      stx))
+
+(define-syntax (~> stx)
+  (syntax-case stx ()
+    [(_ v) #'v]
+    [(_ v f . f*) #'(~> (f v) . f*)]))
+
+(define-syntax-parameter #%dotted-id
+  (syntax-parser
+    #:literals (#%dot-separator)
+    [(_ {~seq #%dot-separator e} …) #'(λ (v) (~> v e …))]
+    [(_ e₀ {~seq #%dot-separator e} …) #'(~> e₀ e …)]))
+
+(define-syntax (new-#%module-begin stx)
+  (syntax-case stx ()
+    [(_ . body)
+     #`(#%module-begin
+        . #,(fold-syntax replace-dots
+                         #'body))]))
+
+(define-for-syntax (make-λ l args e percent?)
+  (define percent*
+    (if (and percent? (>= (length args) 1))
+        `{(,#'define-syntax % (make-rename-transformer #',(car args)))}
+        '{}))
+  ;`(letrec ([%0 (,#'λ ,args ,@percent* ,e)]) %0)
+  (datum->syntax l `(,#'λ ,args ,@percent* ,e) l l))
+
+(define-for-syntax (make-args l str* pos)
+  (if (empty? str*)
+      '()
+      (let ()
+        (define str (car str*))
+        (define len (string-length str))
+        (cons (datum->syntax l
+                             (string->symbol str)
+                             (update-source-location l
+                                                     #:position pos
+                                                     #:span len)
+                             l)
+              (make-args l (cdr str*) (+ pos 1 len))))))
+
+(define-for-syntax (find-% stx)
+  (define found 0)
+  (define (found! n) (set! found (max found n)))
+  (fold-syntax (λ (e recurse)
+                 (if (and (identifier? e)
+                          (regexp-match #px"^%[1-9][0-9]*$"
+                                        (identifier→string e)))
+                     (found! (string->number
+                              (cadr (regexp-match #px"^%([1-9][0-9]*)$"
+                                                  (identifier→string e)))))
+                     (if (and (identifier? e)
+                              (string=? (identifier→string e) "%"))
+                         (found! 1)
+                         (recurse e))))
+               stx)
+  found)
+
+(begin-for-syntax
+  (define-splicing-syntax-class elt
+    (pattern {~seq {~and l {~datum λ.}} e:expr}
+             #:with expanded
+             (let ([args (for/list ([arg (in-range 1 (add1 (find-% #'e)))])
+                           (datum->syntax #'l
+                                          (string->symbol (format "%~a" arg))
+                                          #'l
+                                          #'l))])
+               (make-λ #'l args #'e #t)))
+    (pattern {~seq l:id e:expr}
+             #:when (regexp-match #px"^λ([^.]+\\.)+$" (identifier→string #'l))
+             #:with expanded
+             (let* ([m (regexp-match* #px"[^.]+" (identifier→string #'l) 1)]
+                    [args (make-args #'l
+                                     m
+                                     (+ (syntax-position #'l) 1))])
+               (make-λ #'l args #'e #f)))
+    (pattern e
+             #:with expanded #'e)))
+
+(define-for-syntax (replace-dots stx recurse)
+  (syntax-parse stx
+    ;; Fast path: no dots or ellipses.
+    [x:id #:when (regexp-match #px"^[^.…]*$" (identifier→string #'x))
+          #'x]
+    ;; Protected identifiers, which are not altered.
+    [x:id #:when (regexp-match #px"^(\\.*|…|\\.\\.\\.?[+*]|…[+*]|::\\.\\.\\.)$"
+                               (identifier→string #'x))
+          #'x]
+    ;; A trailing dot is dropped and escapes the preceding identifier.
+    [x:id #:when (regexp-match #px"\\.$" (identifier→string #'x))
+          (let* ([str (identifier→string #'x)]
+                 [unescaped (substring str 0 (sub1 (string-length str)))])
+            (datum->syntax stx (string->symbol unescaped) stx stx))]
+    [x:id #:when (regexp-match #px"[.…]"
+                               (identifier→string #'x))
+          (let* ([str (symbol->string (syntax-e #'x))]
+                 [leading-dot? (regexp-match #px"^\\." str)]
+                 [components* (regexp-match* #px"([^.…]|\\.\\.+)+|…"
+                                             str
+                                             #:gap-select? #t)]
+                 [components (if leading-dot?
+                                 (drop-right components* 1)
+                                 (cdr (drop-right components* 1)))]
+                 [unescaped (map (λ (m)
+                                   (regexp-replace* #px"\\.(\\.+)" m "\\1"))
+                                 components)]
+                 [identifiers ((to-ids stx) components
+                                            unescaped
+                                            0
+                                            leading-dot?)]
+                 [trailing-dot? (regexp-match #px"\\.$" str)])
+            (define/with-syntax (id …) identifiers)
+            (if (= (length identifiers) 1)
+                (quasisyntax/loc stx
+                  #,(car identifiers))
+                (quasisyntax/loc stx
+                  (#,(datum->syntax #'here '#%dotted-id stx stx) id …))))]
+    [{~and whole (:elt … . {~and tail {~not (_ . _)}})}
+     ;; TODO: keep the stx-pairs vs stx-lists structure where possible.
+     (recurse (datum->syntax #'whole
+                             (syntax-e #'(expanded … . tail))
+                             #'whole
+                             #'whole))]
+    [_ (datum->syntax stx (recurse stx) stx stx)]))
+
+(define-for-syntax (to-ids stx)
+  (define (process component* unescaped* len-before dot?)
+    (if (empty? component*)
+        '()
+        (let ()
+          (define component (car component*))
+          (define unescaped (car unescaped*))
+          (define len (string-length component))
+          (define len-after (+ len-before len))
+          (define pos (+ (syntax-position stx) len-before))
+          (define loc (update-source-location stx #:position pos #:span len))
+          (define id
+            (datum->syntax stx
+                           (if dot?
+                               '#%dot-separator
+                               (string->symbol unescaped))
+                           loc
+                           stx))
+          (define id-p
+            (if dot? (syntax-property id 'dotted-original-chars unescaped) id))
+          (cons id-p
+                (process (cdr component*)
+                         (cdr unescaped*)
+                         len-after
+                         (not dot?))))))
+  process)
+
+(define-for-syntax (map-fold f init . l*)
+  (car
+   (apply foldl
+          (λ all-args
+            (define vs+acc (last all-args))
+            (define args (drop-right all-args 1))
+            (define new-v+new-acc (apply f (append args (list (cdr vs+acc)))))
+            (cons (cons (car new-v+new-acc)
+                        (car vs+acc))
+                  (cdr new-v+new-acc)))
+          (cons '() init)
+          l*)))
\ No newline at end of file
diff --git a/lang.rkt b/lang.rkt
deleted file mode 100644
index 2f20414..0000000
--- a/lang.rkt
+++ /dev/null
@@ -1,6 +0,0 @@
-#lang racket
-
-(require dotlambda
-         (except-in typed/racket #%module-begin))
-(provide (except-out (all-from-out typed/racket))
-         (all-from-out dotlambda))
\ No newline at end of file
diff --git a/main.rkt b/main.rkt
index 82e643e..2f20414 100644
--- a/main.rkt
+++ b/main.rkt
@@ -1,190 +1,6 @@
 #lang racket
-(provide #%dotted-id
-         #%dot-separator
-         (rename-out [new-#%module-begin #%module-begin]))
 
-(require typed/racket)
-  
-(require (submod phc-toolkit untyped)
-         racket/stxparam
-         (for-syntax racket/string
-                     racket/list
-                     syntax/parse
-                     racket/syntax
-                     syntax/strip-context
-                     racket/struct
-                     racket/function
-                     syntax/srcloc
-                     phc-toolkit/stx/fold
-                     (only-in racket/base [... …])))
-
-(define-for-syntax identifier→string (compose symbol->string syntax-e))
-
-(define-syntax (#%dot-separator stx)
-  (raise-syntax-error '#%dot-separator
-                      "Can only be used in special contexts"
-                      stx))
-
-(define-syntax (~> stx)
-  (syntax-case stx ()
-    [(_ v) #'v]
-    [(_ v f . f*) #'(~> (f v) . f*)]))
-
-(define-syntax-parameter #%dotted-id
-  (syntax-parser
-    #:literals (#%dot-separator)
-    [(_ {~seq #%dot-separator e} …) #'(λ (v) (~> v e …))]
-    [(_ e₀ {~seq #%dot-separator e} …) #'(~> e₀ e …)]))
-
-(define-syntax (new-#%module-begin stx)
-  (syntax-case stx ()
-    [(_ . body)
-     #`(#%module-begin
-        . #,(fold-syntax replace-dots
-                         #'body))]))
-
-(define-for-syntax (make-λ l args e percent?)
-  (define percent*
-    (if (and percent? (>= (length args) 1))
-        `{(,#'define-syntax % (make-rename-transformer #',(car args)))}
-        '{}))
-  ;`(letrec ([%0 (,#'λ ,args ,@percent* ,e)]) %0)
-  (datum->syntax l `(,#'λ ,args ,@percent* ,e) l l))
-
-(define-for-syntax (make-args l str* pos)
-  (if (empty? str*)
-      '()
-      (let ()
-        (define str (car str*))
-        (define len (string-length str))
-        (cons (datum->syntax l
-                             (string->symbol str)
-                             (update-source-location l
-                                                     #:position pos
-                                                     #:span len)
-                             l)
-              (make-args l (cdr str*) (+ pos 1 len))))))
-
-(define-for-syntax (find-% stx)
-  (define found 0)
-  (define (found! n) (set! found (max found n)))
-  (fold-syntax (λ (e recurse)
-                 (if (and (identifier? e)
-                          (regexp-match #px"^%[1-9][0-9]*$"
-                                        (identifier→string e)))
-                     (found! (string->number
-                              (cadr (regexp-match #px"^%([1-9][0-9]*)$"
-                                                  (identifier→string e)))))
-                     (if (and (identifier? e)
-                              (string=? (identifier→string e) "%"))
-                         (found! 1)
-                         (recurse e))))
-               stx)
-  found)
-
-(begin-for-syntax
-  (define-splicing-syntax-class elt
-    (pattern {~seq {~and l {~datum λ.}} e:expr}
-             #:with expanded
-             (let ([args (for/list ([arg (in-range 1 (add1 (find-% #'e)))])
-                           (datum->syntax #'l
-                                          (string->symbol (format "%~a" arg))
-                                          #'l
-                                          #'l))])
-               (make-λ #'l args #'e #t)))
-    (pattern {~seq l:id e:expr}
-             #:when (regexp-match #px"^λ([^.]+\\.)+$" (identifier→string #'l))
-             #:with expanded
-             (let* ([m (regexp-match* #px"[^.]+" (identifier→string #'l) 1)]
-                    [args (make-args #'l
-                                     m
-                                     (+ (syntax-position #'l) 1))])
-               (make-λ #'l args #'e #f)))
-    (pattern e
-             #:with expanded #'e)))
-
-(define-for-syntax (replace-dots stx recurse)
-  (syntax-parse stx
-    ;; Fast path: no dots or ellipses.
-    [x:id #:when (regexp-match #px"^[^.…]*$" (identifier→string #'x))
-          #'x]
-    ;; Protected identifiers, which are not altered.
-    [x:id #:when (regexp-match #px"^(\\.*|…|\\.\\.\\.?[+*]|…[+*]|::\\.\\.\\.)$"
-                               (identifier→string #'x))
-          #'x]
-    ;; A trailing dot is dropped and escapes the preceding identifier.
-    [x:id #:when (regexp-match #px"\\.$" (identifier→string #'x))
-          (let* ([str (identifier→string #'x)]
-                 [unescaped (substring str 0 (sub1 (string-length str)))])
-            (datum->syntax stx (string->symbol unescaped) stx stx))]
-    [x:id #:when (regexp-match #px"[.…]"
-                               (identifier→string #'x))
-          (let* ([str (symbol->string (syntax-e #'x))]
-                 [leading-dot? (regexp-match #px"^\\." str)]
-                 [components* (regexp-match* #px"([^.…]|\\.\\.+)+|…"
-                                             str
-                                             #:gap-select? #t)]
-                 [components (if leading-dot?
-                                 (drop-right components* 1)
-                                 (cdr (drop-right components* 1)))]
-                 [unescaped (map (λ (m)
-                                   (regexp-replace* #px"\\.(\\.+)" m "\\1"))
-                                 components)]
-                 [identifiers ((to-ids stx) components
-                                            unescaped
-                                            0
-                                            leading-dot?)]
-                 [trailing-dot? (regexp-match #px"\\.$" str)])
-            (define/with-syntax (id …) identifiers)
-            (if (= (length identifiers) 1)
-                (quasisyntax/loc stx
-                  #,(car identifiers))
-                (quasisyntax/loc stx
-                  (#,(datum->syntax #'here '#%dotted-id stx stx) id …))))]
-    [{~and whole (:elt … . {~and tail {~not (_ . _)}})}
-     ;; TODO: keep the stx-pairs vs stx-lists structure where possible.
-     (recurse (datum->syntax #'whole
-                             (syntax-e #'(expanded … . tail))
-                             #'whole
-                             #'whole))]
-    [_ (datum->syntax stx (recurse stx) stx stx)]))
-
-(define-for-syntax (to-ids stx)
-  (define (process component* unescaped* len-before dot?)
-    (if (empty? component*)
-        '()
-        (let ()
-          (define component (car component*))
-          (define unescaped (car unescaped*))
-          (define len (string-length component))
-          (define len-after (+ len-before len))
-          (define pos (+ (syntax-position stx) len-before))
-          (define loc (update-source-location stx #:position pos #:span len))
-          (define id
-            (datum->syntax stx
-                           (if dot?
-                               '#%dot-separator
-                               (string->symbol unescaped))
-                           loc
-                           stx))
-          (define id-p
-            (if dot? (syntax-property id 'dotted-original-chars unescaped) id))
-          (cons id-p
-                (process (cdr component*)
-                         (cdr unescaped*)
-                         len-after
-                         (not dot?))))))
-  process)
-
-(define-for-syntax (map-fold f init . l*)
-  (car
-   (apply foldl
-          (λ all-args
-            (define vs+acc (last all-args))
-            (define args (drop-right all-args 1))
-            (define new-v+new-acc (apply f (append args (list (cdr vs+acc)))))
-            (cons (cons (car new-v+new-acc)
-                        (car vs+acc))
-                  (cdr new-v+new-acc)))
-          (cons '() init)
-          l*)))
\ No newline at end of file
+(require dotlambda
+         (except-in typed/racket #%module-begin))
+(provide (except-out (all-from-out typed/racket))
+         (all-from-out dotlambda))
\ No newline at end of file