Made separate typed/dotlambda and dotlambda languages.

.gitignore

@@ -3,4 +3,4 @@
 .\#*
 .DS_Store
 compiled/
-/doc/
+/dotlambda/doc/

dotlambda/implementation.rkt

@@ -1,8 +1,8 @@
 #lang racket
 (provide #%dotted-id
          #%dot-separator
-         (rename-out [new-#%module-begin #%module-begin]
+         make-#%module-begin
-                     [new-#%top-interaction #%top-interaction]))
+         make-#%top-interaction)
 
 (require typed/racket)
   
@@ -37,27 +37,35 @@
     [(_ {~seq #%dot-separator e} …) #'(λ (v) (~> v e …))]
     [(_ e₀ {~seq #%dot-separator e} …) #'(~> e₀ e …)]))
 
-(define-syntax (new-#%module-begin stx)
+(define-syntax (make-#%module-begin stx)
   (syntax-case stx ()
-    [(_ . body)
+    ;; -mrt = -make-rename-transformer
-     #`(#%module-begin
+    [(_ name wrapped-#%module-begin -λ -define-syntax -mrt)
-        . #,(fold-syntax replace-dots
+     #'(define-syntax (name stx2)
-                         #'body))]))
+         (syntax-case stx2 ()
+           [(_ . body)
+            #`(wrapped-#%module-begin
+               . #,(fold-syntax (replace-dots #'-λ #'-define-syntax #'-mrt)
+                                #'body))]))]))
 
-(define-syntax (new-#%top-interaction stx)
+(define-syntax (make-#%top-interaction stx)
   (syntax-case stx ()
-    [(_ . body)
+    ;; -mrt = -make-rename-transformer
-     #`(#%top-interaction
+    [(_ name wrapped-#%top-interaction -λ -define-syntax -mrt)
-        . #,(fold-syntax replace-dots
+     #'(define-syntax (name stx2)
-                         #'body))]))
+         (syntax-case stx2 ()
+           [(_ . body)
+            #`(wrapped-#%top-interaction
+               . #,(fold-syntax (replace-dots #'-λ #'-define-syntax #'-mrt)
+                                #'body))]))]))
 
-(define-for-syntax (make-λ l args e percent?)
+(define-for-syntax (make-λ l args e percent? -λ -define-syntax -mrt)
   (define percent*
     (if (and percent? (>= (length args) 1))
-        `{(,#'define-syntax % (make-rename-transformer #',(car args)))}
+        `{(,-define-syntax % (,-mrt #',(car args)))}
         '{}))
   ;`(letrec ([%0 (,#'λ ,args ,@percent* ,e)]) %0)
-  (datum->syntax l `(,#'λ ,args ,@percent* ,e) l l))
+  (datum->syntax l `(,-λ ,args ,@percent* ,e) l l))
 
 (define-for-syntax (make-args l str* pos)
   (if (empty? str*)
@@ -91,7 +99,7 @@
   found)
 
 (begin-for-syntax
-  (define-splicing-syntax-class elt
+  (define-splicing-syntax-class (elt -λ -define-syntax -mrt)
     (pattern {~seq {~and l {~datum λ.}} e:expr}
              #:with expanded
              (let ([args (for/list ([arg (in-range 1 (add1 (find-% #'e)))])
@@ -99,7 +107,7 @@
                                           (string->symbol (format "%~a" arg))
                                           #'l
                                           #'l))])
-               (make-λ #'l args #'e #t)))
+               (make-λ #'l args #'e #t -λ -define-syntax -mrt)))
     (pattern {~seq l:id e:expr}
              #:when (regexp-match #px"^λ([^.]+\\.)+$" (identifier→string #'l))
              #:with expanded
@@ -107,11 +115,11 @@
                     [args (make-args #'l
                                      m
                                      (+ (syntax-position #'l) 1))])
-               (make-λ #'l args #'e #f)))
+               (make-λ #'l args #'e #f -λ -define-syntax -mrt)))
     (pattern e
              #:with expanded #'e)))
 
-(define-for-syntax (replace-dots stx recurse)
+(define-for-syntax ((replace-dots -λ -define-syntax -mrt) stx recurse)
   (syntax-parse stx
     ;; Fast path: no dots or ellipses.
     [x:id #:when (regexp-match #px"^[^.…]*$" (identifier→string #'x))
@@ -149,13 +157,14 @@
                   #,(car identifiers))
                 (quasisyntax/loc stx
                   (#,(datum->syntax #'here '#%dotted-id stx stx) id …))))]
-    [{~and whole (:elt … . {~and tail {~not (_ . _)}})}
+    [{~and whole ({~var || (elt -λ -define-syntax -mrt)} …
+                  . {~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)]))
+    [_ (recurse stx)]))
 
 (define-for-syntax (to-ids stx)
   (define (process component* unescaped* len-before dot?)

dotlambda/info.rkt

@@ -0,0 +1,2 @@
+#lang info
+(define scribblings '(("scribblings/dotlambda.scrbl" ())))

dotlambda/main.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+
+(require dotlambda/implementation
+         (for-syntax racket/base))
+
+(make-#%module-begin new-#%module-begin
+                     #%module-begin
+                     λ
+                     define-syntax
+                     make-rename-transformer)
+(make-#%top-interaction new-#%top-interaction
+                        #%top-interaction
+                        λ
+                        define-syntax
+                        make-rename-transformer)
+
+(provide (except-out (all-from-out racket/base)
+                     #%module-begin
+                     #%top-interaction)
+         (except-out (all-from-out dotlambda/implementation)
+                     make-#%module-begin
+                     make-#%top-interaction)
+         (rename-out [new-#%module-begin #%module-begin]
+                     [new-#%top-interaction #%top-interaction]))

dotlambda/scribblings/dotlambda.scrbl

@@ -6,17 +6,19 @@
 @author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
 
 @(begin
-   (module orig racket/base
+   (module orig-racket/base racket/base
-     (require scribble/manual
+     (require scribble/manual)
-              typed/racket/base)
+     (provide racket/base:#%module-begin
-     (provide orig:#%module-begin)
+              racket/base:#%top-interaction)
-     (define orig:#%module-begin (racket #%module-begin)))
+     (define racket/base:#%module-begin (racket #%module-begin))
-   (require 'orig))
+     (define racket/base:#%top-interaction (racket #%top-interaction)))
+   (require 'orig-racket/base))
 
 @defmodulelang[dotlambda]{
- This @hash-lang[] language overrides @orig:#%module-begin from
+ This @hash-lang[] language overrides @racket/base:#%module-begin and
- @racketmodname[typed/racket/base], and splits identifiers which contain dots,
+ @racket/base:#%top-interaction from @racketmodname[racket/base], and splits
- following these rules:
+ identifiers which contain dots, following these rules:
+ 
  @itemlist[
  @item{A single dot splits the identifier, and the dot is replaced with
    @racket[#%dot-separator]. If an identifier is split by one or more
@@ -82,4 +84,6 @@
  (usually @racket["."] or the empty string @racket[""] for an implicit dot
  before or after an ellipsis) is normally stored in the
  @racket['dotted-original-chars] syntax property of the occurrence of the
- @racket[#%dot-separator] identifier.}
+ @racket[#%dot-separator] identifier.}
+
+@include-section{typed-dotlambda.scrbl}

dotlambda/scribblings/typed-dotlambda.scrbl

@@ -0,0 +1,20 @@
+#lang scribble/manual
+@require[@for-label[@only-in[dotlambda #%dot-separator #%dotted-id]
+                    racket/stxparam]]
+
+@title{Typed version of @racketmodname[dotlambda]}
+
+@(begin
+   (module orig-typed/racket/base racket/base
+     (require scribble/manual
+              typed/racket/base)
+     (provide typed/racket/base:#%module-begin
+              typed/racket/base:#%top-interaction)
+     (define typed/racket/base:#%module-begin (racket #%module-begin))
+     (define typed/racket/base:#%top-interaction (racket #%top-interaction)))
+   (require 'orig-typed/racket/base))
+
+@defmodulelang[typed/dotlambda]{
+ Like @racket[#,(hash-lang) dotlambda], but overrides
+ @typed/racket/base:#%module-begin and @typed/racket/base:#%top-interaction
+ from @racketmodname[typed/racket/base], instead.}

dotlambda/test/test-dotlambda.rkt

@@ -0,0 +1,95 @@
+#lang dotlambda
+
+(require rackunit
+         (for-syntax racket/base))
+
+(require racket/stxparam)
+
+(check-equal?
+ (syntax-parameterize ([#%dotted-id (make-rename-transformer #'list)])
+   (let ([x 1] [y 2] [z 3] [#%dot-separator '|.|])
+     (list 'x.y
+           '.x.y
+           x.y
+           .x.y)))
+ '((#%dotted-id x #%dot-separator y)
+   (#%dotted-id #%dot-separator x #%dot-separator y)
+   (1 |.| 2)
+   (|.| 1 |.| 2)))
+
+(check-equal? (let ([v 4]) v.sqrt.-) -2)
+
+(let ((foo..bar 42))
+  (check-equal? foo..bar 42))
+
+(define di '#%dotted-id)
+(define d '#%dot-separator)
+
+(check-equal? 'foo.bar (list di 'foo d 'bar))
+
+;; Srcloc tests:
+;(let .a b) ;; Error on the whole .a
+;(let .a.b b) ;; Error on the whole .a.b
+;(let a.b b) ;; Error on the whole a.b
+  
+(define (slen n str)
+  (check-equal? (string-length str) n)
+  (string->symbol str))
+  
+(check-equal? '(a . b) (cons 'a 'b))
+(check-equal? '(a . b.c) (list 'a di 'b d 'c))
+(check-equal? '(a . b.c.d) (list 'a di 'b d 'c d 'd))
+(check-equal? '(a.c . b) (cons (list di 'a d 'c) 'b))
+(check-equal? '(a.c.d . b) (cons (list di 'a d 'c d 'd) 'b))
+  
+(check-equal? '.aa.bb..cc.d (list di d 'aa d (slen 5 "bb.cc") d 'd))
+(check-equal? '…aa...bb..cc.d (list di '… d (slen 9 "aa..bb.cc") d 'd))
+(check-equal? '.…aa...bb..cc.d (list di d '… d (slen 9 "aa..bb.cc") d 'd))
+(check-equal? '…aa.….bb..cc.d
+              (list di '… d 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? '.…aa.….bb..cc.d
+              (list di d '… d 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? '.aa.….bb..cc.d (list di d 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? '.aa.….bb.cc.d (list di d 'aa d '… d 'bb d 'cc d 'd))
+(check-equal? '…aa.….bb.cc.d (list di '… d 'aa d '… d 'bb d 'cc d 'd))
+(check-equal? '.…aa.….bb.cc.d (list di d '… d 'aa d '… d 'bb d 'cc d 'd))
+  
+(check-equal? 'aa.bb..cc.d (list di 'aa d (slen 5 "bb.cc") d 'd))
+(check-equal? 'aa...bb..cc.d (list di (slen 9 "aa..bb.cc") d 'd))
+(check-equal? 'aa…bb..cc.d (list di 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? 'aa.….bb..cc.d (list di 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? 'aa.….bb.cc.d (list di 'aa d '… d 'bb d 'cc d 'd))
+
+(check-equal? 'aa…bb (list di 'aa d '… d 'bb))
+(check-equal? 'aa… (list di 'aa d '…))
+(check-equal? 'aa…. (slen 3 "aa…"))
+(check-equal? 'aa.. (slen 3 "aa."))
+(check-equal? 'aa... (slen 4 "aa.."))
+  
+(check-equal? '… (slen 1 "…"))
+(check-equal? '…+ (slen 2 "…+"))
+(check-equal? '... (slen 3 "..."))
+(check-equal? '...+ (slen 4 "...+"))
+
+(check-equal? (λx.(+ x x) 3) 6)
+(check-equal? (λy.(+ y y) 3) 6)
+(check-equal? (λ.(+ % %) 3) 6)
+(check-equal? (λy.(+ y) 3) 3)
+(check-equal? (λy. y.sqrt.- 4) -2)
+(check-equal? (.sqrt.- 4) -2)
+
+(check-equal? '…aa.…bb..cc.d (list di '… d 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? '…aa….bb..cc.d (list di '… d 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? '.…aa.…bb..cc.d
+              (list di d '… d 'aa d '… d (slen 5 "bb.cc") d 'd))
+(check-equal? '.…aa….bb..cc.d
+              (list di d '… d 'aa d '… d (slen 5 "bb.cc") d 'd))
+
+
+(check-equal? (map λx.(* x x) '(1 2 3)) '(1 4 9))
+(check-equal? (map λ.(* % %) '(1 2 3)) '(1 4 9))
+(check-equal? (map λ.(* %1 %2) '(1 2 3) '(10 100 1000)) '(10 200 3000))
+(check-equal? (map λx.y.(* x y) '(1 2 3) '(10 100 1000)) '(10 200 3000))
+
+;; Factorial function, works only in untyped racket due to recursion:
+;; ((λ.(if (> % 0) (* %1 (%0 (sub1 %))) 1)) 5)

dotlambda/test/test-typed-dotlambda.rkt

@@ -1,11 +1,10 @@
-#lang dotlambda
+#lang typed/dotlambda
 
-(require typed/rackunit
+(require phc-toolkit/typed-rackunit
-         phc-toolkit
          ;"get.lp2.rkt"
          ;"graph-test.rkt"
          typed-map
-         )
+         (for-syntax racket/base))
 
 (require racket/stxparam)
 

info.rkt

@@ -1,5 +1,5 @@
 #lang info
-(define collection "dotlambda")
+(define collection 'multi)
 (define deps '("base"
                "rackunit-lib"
                "phc-toolkit"
@@ -9,8 +9,7 @@
 (define build-deps '("scribble-lib"
                      "racket-doc"
                      "typed-racket-doc"))
-(define scribblings '(("scribblings/dotlambda.scrbl" ())))
 (define pkg-desc
-  "Splits dotted identifiers like a.b.c, also supports λ<arg>.code syntax")
+  "Splits dotted identifiers like a.b.c, also supports λ<arg>.(code) syntax")
-(define version "0.1")
+(define version "0.2")
-(define pkg-authors '(georges))
+(define pkg-authors '("Georges Dupéron"))

main.rkt

@@ -1,8 +0,0 @@
-#lang racket
-
-(require dotlambda/implementation
-         (except-in typed/racket
-                    #%module-begin
-                    #%top-interaction))
-(provide (except-out (all-from-out typed/racket))
-         (all-from-out dotlambda/implementation))

typed/dotlambda.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+
+(require dotlambda/implementation
+         typed/racket/base
+         (for-syntax racket/base))
+
+(make-#%module-begin new-#%module-begin
+                     #%module-begin
+                     λ
+                     define-syntax
+                     make-rename-transformer)
+(make-#%top-interaction new-#%top-interaction
+                        #%top-interaction
+                        λ
+                        define-syntax
+                        make-rename-transformer)
+
+(provide (except-out (all-from-out typed/racket/base)
+                     #%module-begin
+                     #%top-interaction)
+         (except-out (all-from-out dotlambda/implementation)
+                     make-#%module-begin
+                     make-#%top-interaction)
+         (rename-out [new-#%module-begin #%module-begin]
+                     [new-#%top-interaction #%top-interaction]))

typed/dotlambda/lang/reader.rkt

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  typed/dotlambda)

typed/dotlambda/main.rkt

@@ -0,0 +1,8 @@
+#lang racket/base
+;; Not sure if this file is necessary. For some reason, #lang typed/dotlambda
+;; tries to access
+;; /home/me/.racket/snapshot/pkgs/alexis-util/typed/dotlambda.rkt
+;; unless there's a typed/dotlambda.rkt file. I would have expected the main.rkt
+;; file to be selected here, but that's not the case.
+(require "../dotlambda.rkt")
+(provide (all-from-out "../dotlambda.rkt"))

typed/info.rkt

@@ -0,0 +1 @@
+#lang info