commit e695af93a134b235b5feb5ee5f064546313fe25f parent e0aeea6a9bb1802f23d258fb6b2ccc90b0d395ce Author: Georges Dupéron <georges.duperon@gmail.com> Date: Sun, 9 Apr 2017 16:28:17 +0200 Made separate typed/dotlambda and dotlambda languages. Diffstat:
| M | .gitignore | | | 2 | +- |
| A | dotlambda/implementation.rkt | | | 208 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | dotlambda/info.rkt | | | 2 | ++ |
| R | lang/reader.rkt -> dotlambda/lang/reader.rkt | | | 0 | |
| R | literals.rkt -> dotlambda/literals.rkt | | | 0 | |
| A | dotlambda/main.rkt | | | 25 | +++++++++++++++++++++++++ |
| A | dotlambda/scribblings/dotlambda.scrbl | | | 90 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | dotlambda/scribblings/typed-dotlambda.scrbl | | | 20 | ++++++++++++++++++++ |
| A | dotlambda/test/test-dotlambda.rkt | | | 96 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | dotlambda/test/test-typed-dotlambda.rkt | | | 109 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| D | implementation.rkt | | | 199 | ------------------------------------------------------------------------------- |
| M | info.rkt | | | 9 | ++++----- |
| D | main.rkt | | | 9 | --------- |
| D | scribblings/dotlambda.scrbl | | | 86 | ------------------------------------------------------------------------------- |
| D | test/test-dotlambda.rkt | | | 110 | ------------------------------------------------------------------------------- |
| A | typed/dotlambda.rkt | | | 26 | ++++++++++++++++++++++++++ |
| A | typed/dotlambda/lang/reader.rkt | | | 3 | +++ |
| A | typed/dotlambda/main.rkt | | | 9 | +++++++++ |
| A | typed/info.rkt | | | 1 | + |
19 files changed, 594 insertions(+), 410 deletions(-)
diff --git a/.gitignore b/.gitignore @@ -3,4 +3,4 @@ .\#* .DS_Store compiled/ -/doc/ +/dotlambda/doc/ diff --git a/dotlambda/implementation.rkt b/dotlambda/implementation.rkt @@ -0,0 +1,207 @@ +#lang racket +(provide #%dotted-id + #%dot-separator + make-#%module-begin + make-#%top-interaction) + +(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 (make-#%module-begin stx) + (syntax-case stx () + ;; -mrt = -make-rename-transformer + [(_ name wrapped-#%module-begin -λ -define-syntax -mrt) + #'(define-syntax (name stx2) + (syntax-case stx2 () + [(_ . body) + #`(wrapped-#%module-begin + . #,(fold-syntax (replace-dots #'-λ #'-define-syntax #'-mrt) + #'body))]))])) + +(define-syntax (make-#%top-interaction stx) + (syntax-case stx () + ;; -mrt = -make-rename-transformer + [(_ name wrapped-#%top-interaction -λ -define-syntax -mrt) + #'(define-syntax (name stx2) + (syntax-case stx2 () + [(_ . body) + #`(wrapped-#%top-interaction + . #,(fold-syntax (replace-dots #'-λ #'-define-syntax #'-mrt) + #'body))]))])) + +(define-for-syntax (make-λ l args e percent? -λ -define-syntax -mrt) + (define percent* + (if (and percent? (>= (length args) 1)) + `{(,-define-syntax % (,-mrt #',(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 -λ -define-syntax -mrt) + (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 -λ -define-syntax -mrt))) + (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 -λ -define-syntax -mrt))) + (pattern e + #:with expanded #'e))) + +(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)) + #'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 ({~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))] + [_ (recurse 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/dotlambda/info.rkt b/dotlambda/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define scribblings '(("scribblings/dotlambda.scrbl" ()))) diff --git a/lang/reader.rkt b/dotlambda/lang/reader.rkt diff --git a/literals.rkt b/dotlambda/literals.rkt diff --git a/dotlambda/main.rkt b/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])) +\ No newline at end of file diff --git a/dotlambda/scribblings/dotlambda.scrbl b/dotlambda/scribblings/dotlambda.scrbl @@ -0,0 +1,89 @@ +#lang scribble/manual +@require[@for-label[@only-in[dotlambda #%dot-separator #%dotted-id] + racket/stxparam]] + +@title{Dotted identifiers and @racket[λ<arg>.code] syntax} +@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]] + +@(begin + (module orig-racket/base racket/base + (require scribble/manual) + (provide racket/base:#%module-begin + racket/base:#%top-interaction) + (define racket/base:#%module-begin (racket #%module-begin)) + (define racket/base:#%top-interaction (racket #%top-interaction))) + (require 'orig-racket/base)) + +@defmodulelang[dotlambda]{ + This @hash-lang[] language overrides @racket/base:#%module-begin and + @racket/base:#%top-interaction from @racketmodname[racket/base], and splits + 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 + non-consecutive dots, all the resulting identifiers, including the + occurrences @racket[#%dot-separator] are placed in a syntax list, starting + with @racket[#%dotted-id], so that @racket[a.b.c] gets transformed into + @racket[(#%dotted-id a #%dot-separator b #%dot-separator c)].} + @item{A leading dot (which is not followed by another dot) is allowed, and is + replaced with @racket[#%dot-separator], like dots occurring in the middle of + the identifier.} + @item{A dot immediately preceded or followed by an ellipsis @racket[…] can be + omitted, so that @racket[a.….b], @racket[a….b], @racket[a.…b] and + @racket[a…b] are all translated to + @racket[(#%dotted-id a #%dot-separator … #%dot-separator b)].} + @item{Two or more dots do not split the identifier, but one of the dots is + removed (i.e. it escapes the other dots).} + @item{If an identifier ends with a dot, a single trailing dot is removed and + the identifier is otherwise left intact (i.e. the trailing dot escapes the + whole identifier).} + @item{Identifiers consisting only of dots are left unchanged, as well as the + following: @racket[..+], @racket[...+], @racket[..*], @racket[...*], + @racket[…], @racket[…+], @racket[…*] and @racket[::...].}] + + Furthermore the syntax @racket[λarg₁.arg₂.….argₙ.(expr …)] is recognised as a + shorthand for @racket[(λ (arg₁ arg₂ … argₙ) (expr …))], so that + @racket[λx.(+ x 2)] is roughly translated to @racket[(λ (x) (+ x 2))]. If the + @racket[_var] part is left empty, then it defaults to @racket[%1], @racket[%2] + and so on. The number of parameters is determined from the syntactical + contents of the function's body, before performing macro-expansion. The term + @racket[λ.(+ %1 %2)] is therefore roughly translated to + @racket[(λ (%1 %2) (+ %1 %2))]. The variable named @racket[%] can be used as a + shorthand for @racket[%1], so that @racket[λ.(+ % 10)] is therefore roughly + translated to @racket[(λ (%) (+ % 10))]. + + Since this substitution is performed on the whole program, before + macro-expansion, these notations are performed regardless of the context in + which an expression occurs. For example, the quoted term @racket['a.b] will + also get translated to @racket['(#%dotted-id a #%dot-separator b)]. In this + way, the @racket[#%module-begin] from @racket[dotlambda] works a bit like if + it were a reader extension. + + @bold{Warning:} There probably are some issues with hygiene, especially in + mixed contexts (e.g. literate programs, or typed/racket programs with untyped + code at phase 1). I will think about these issues and adjust the behaviour in + future versions. Future versions may therefore not be 100% backward-compatible + with the current version, but the general syntax of dotted identifiers should + hopefully not change much.} + +@defform[#:kind "syntax parameter" + (#%dotted-id ids-and-separators …)]{ + The default implementation currently translates @racket[a.b.c.d] to + @racket[(d (c (b a)))], and @racket[.a.b.c] to + @racket[(λ (x) (c (b (a x))))]. + + This behaviour can be altered using @racket[syntax-parameterize]. I don't + think syntax parameters can be modified globally for the whole containing file + like parameters can (via @racket[(param new-value)]), so the exact mechanism + used to customise the behaviour of @racket[#%dotted-id] may change in the + future.} + +@defidform[#%dot-separator]{ + Indicates the presence of a (possibly implicit) dot. The original string + (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.} + +@include-section{typed-dotlambda.scrbl} +\ No newline at end of file diff --git a/dotlambda/scribblings/typed-dotlambda.scrbl b/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.} diff --git a/dotlambda/test/test-dotlambda.rkt b/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) +\ No newline at end of file diff --git a/dotlambda/test/test-typed-dotlambda.rkt b/dotlambda/test/test-typed-dotlambda.rkt @@ -0,0 +1,108 @@ +#lang typed/dotlambda + +(require phc-toolkit/typed-rackunit + ;"get.lp2.rkt" + ;"graph-test.rkt" + typed-map + (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 + +#| +TODO: re-enable or move these tests. +(check-equal?: g.streets…houses…owner.name + : (Listof (Listof String)) + (list (list "Amy" "Anabella") (list "Jack"))) +(check-equal?: (map: (curry map .owner.name) g.streets…houses) + : (Listof (Listof String)) + (list (list "Amy" "Anabella") (list "Jack"))) +|# + +(define (slen [n : Index] [str : String]) + (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) +\ No newline at end of file diff --git a/implementation.rkt b/implementation.rkt @@ -1,198 +0,0 @@ -#lang racket -(provide #%dotted-id - #%dot-separator - (rename-out [new-#%module-begin #%module-begin] - [new-#%top-interaction #%top-interaction])) - -(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-syntax (new-#%top-interaction stx) - (syntax-case stx () - [(_ . body) - #`(#%top-interaction - . #,(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/info.rkt b/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") -(define version "0.1") -(define pkg-authors '(georges)) + "Splits dotted identifiers like a.b.c, also supports λ<arg>.(code) syntax") +(define version "0.2") +(define pkg-authors '("Georges Dupéron")) diff --git a/main.rkt b/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)) -\ No newline at end of file diff --git a/scribblings/dotlambda.scrbl b/scribblings/dotlambda.scrbl @@ -1,85 +0,0 @@ -#lang scribble/manual -@require[@for-label[@only-in[dotlambda #%dot-separator #%dotted-id] - racket/stxparam]] - -@title{Dotted identifiers and @racket[λ<arg>.code] syntax} -@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]] - -@(begin - (module orig racket/base - (require scribble/manual - typed/racket/base) - (provide orig:#%module-begin) - (define orig:#%module-begin (racket #%module-begin))) - (require 'orig)) - -@defmodulelang[dotlambda]{ - This @hash-lang[] language overrides @orig:#%module-begin from - @racketmodname[typed/racket/base], and splits 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 - non-consecutive dots, all the resulting identifiers, including the - occurrences @racket[#%dot-separator] are placed in a syntax list, starting - with @racket[#%dotted-id], so that @racket[a.b.c] gets transformed into - @racket[(#%dotted-id a #%dot-separator b #%dot-separator c)].} - @item{A leading dot (which is not followed by another dot) is allowed, and is - replaced with @racket[#%dot-separator], like dots occurring in the middle of - the identifier.} - @item{A dot immediately preceded or followed by an ellipsis @racket[…] can be - omitted, so that @racket[a.….b], @racket[a….b], @racket[a.…b] and - @racket[a…b] are all translated to - @racket[(#%dotted-id a #%dot-separator … #%dot-separator b)].} - @item{Two or more dots do not split the identifier, but one of the dots is - removed (i.e. it escapes the other dots).} - @item{If an identifier ends with a dot, a single trailing dot is removed and - the identifier is otherwise left intact (i.e. the trailing dot escapes the - whole identifier).} - @item{Identifiers consisting only of dots are left unchanged, as well as the - following: @racket[..+], @racket[...+], @racket[..*], @racket[...*], - @racket[…], @racket[…+], @racket[…*] and @racket[::...].}] - - Furthermore the syntax @racket[λarg₁.arg₂.….argₙ.(expr …)] is recognised as a - shorthand for @racket[(λ (arg₁ arg₂ … argₙ) (expr …))], so that - @racket[λx.(+ x 2)] is roughly translated to @racket[(λ (x) (+ x 2))]. If the - @racket[_var] part is left empty, then it defaults to @racket[%1], @racket[%2] - and so on. The number of parameters is determined from the syntactical - contents of the function's body, before performing macro-expansion. The term - @racket[λ.(+ %1 %2)] is therefore roughly translated to - @racket[(λ (%1 %2) (+ %1 %2))]. The variable named @racket[%] can be used as a - shorthand for @racket[%1], so that @racket[λ.(+ % 10)] is therefore roughly - translated to @racket[(λ (%) (+ % 10))]. - - Since this substitution is performed on the whole program, before - macro-expansion, these notations are performed regardless of the context in - which an expression occurs. For example, the quoted term @racket['a.b] will - also get translated to @racket['(#%dotted-id a #%dot-separator b)]. In this - way, the @racket[#%module-begin] from @racket[dotlambda] works a bit like if - it were a reader extension. - - @bold{Warning:} There probably are some issues with hygiene, especially in - mixed contexts (e.g. literate programs, or typed/racket programs with untyped - code at phase 1). I will think about these issues and adjust the behaviour in - future versions. Future versions may therefore not be 100% backward-compatible - with the current version, but the general syntax of dotted identifiers should - hopefully not change much.} - -@defform[#:kind "syntax parameter" - (#%dotted-id ids-and-separators …)]{ - The default implementation currently translates @racket[a.b.c.d] to - @racket[(d (c (b a)))], and @racket[.a.b.c] to - @racket[(λ (x) (c (b (a x))))]. - - This behaviour can be altered using @racket[syntax-parameterize]. I don't - think syntax parameters can be modified globally for the whole containing file - like parameters can (via @racket[(param new-value)]), so the exact mechanism - used to customise the behaviour of @racket[#%dotted-id] may change in the - future.} - -@defidform[#%dot-separator]{ - Indicates the presence of a (possibly implicit) dot. The original string - (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.} -\ No newline at end of file diff --git a/test/test-dotlambda.rkt b/test/test-dotlambda.rkt @@ -1,109 +0,0 @@ -#lang dotlambda - -(require typed/rackunit - phc-toolkit - ;"get.lp2.rkt" - ;"graph-test.rkt" - typed-map - ) - -(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 - -#| -TODO: re-enable or move these tests. -(check-equal?: g.streets…houses…owner.name - : (Listof (Listof String)) - (list (list "Amy" "Anabella") (list "Jack"))) -(check-equal?: (map: (curry map .owner.name) g.streets…houses) - : (Listof (Listof String)) - (list (list "Amy" "Anabella") (list "Jack"))) -|# - -(define (slen [n : Index] [str : String]) - (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) -\ No newline at end of file diff --git a/typed/dotlambda.rkt b/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])) +\ No newline at end of file diff --git a/typed/dotlambda/lang/reader.rkt b/typed/dotlambda/lang/reader.rkt @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + typed/dotlambda) +\ No newline at end of file diff --git a/typed/dotlambda/main.rkt b/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")) +\ No newline at end of file diff --git a/typed/info.rkt b/typed/info.rkt @@ -0,0 +1 @@ +#lang info