Fixes FB case 79 (… as punctuation), case 44 (test for … and (a . b)), case 84 (tests), and case 82 (replace in-depth, so that repalcements are done in macros too).
This commit is contained in:
Georges Dupéron
parent
f8edadc1a8
commit
d6c6f86544
|
|
@ -1,27 +0,0 @@
|
|||
#lang s-exp "graph/dotlang.rkt"
|
||||
|
||||
(require "graph/graph4.lp2.rkt")
|
||||
(require "graph/map4.rkt")
|
||||
(require (submod "graph/graph3.lp2.rkt" test))
|
||||
(require "type-expander/type-expander.lp2.rkt")
|
||||
(require "graph/structure.lp2.rkt")
|
||||
(require "graph/variant.lp2.rkt")
|
||||
(require "lib/low.rkt")
|
||||
|
||||
#|
|
||||
.aa.bb..cc.d
|
||||
…aa...bb..cc.d
|
||||
…aa.….bb..cc.d
|
||||
.aa.….bb..cc.d
|
||||
(newline)
|
||||
aa.bb..cc.d
|
||||
aa...bb..cc.d
|
||||
aa…bb..cc.d
|
||||
aa.….bb..cc.d
|
||||
(newline)
|
||||
…aa.…bb..cc.d ;; TODO: should cause error
|
||||
…aa….bb..cc.d ;; TODO: should cause error
|
||||
|#
|
||||
|
||||
g.streets…houses…owner.name
|
||||
(map: (curry map (λget owner name)) g.streets…houses)
|
||||
|
|
@ -3,16 +3,25 @@
|
|||
(module dotlang racket
|
||||
(require typed/racket)
|
||||
|
||||
(provide (except-out (all-from-out typed/racket) #%top)
|
||||
(rename-out [new-#%top #%top]))
|
||||
(provide (except-out (all-from-out typed/racket)
|
||||
#;#%top
|
||||
#%module-begin)
|
||||
(rename-out #;[new-#%top #%top]
|
||||
[new-#%module-begin #%module-begin]))
|
||||
|
||||
(require "graph4.lp2.rkt"
|
||||
"../lib/low-untyped.rkt"
|
||||
(for-syntax racket/string
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
syntax/stx
|
||||
syntax/strip-context
|
||||
racket/struct
|
||||
racket/function
|
||||
syntax/srcloc
|
||||
"../lib/low-untyped.rkt"))
|
||||
|
||||
#|
|
||||
(define-syntax/parse (dot x:id)
|
||||
(let* ([str (symbol->string (syntax-e #'x))]
|
||||
[components (regexp-match* #px"([^.…]|\\.\\.+)+|…" str)]
|
||||
|
|
@ -27,19 +36,125 @@
|
|||
[leading-dot? #'(λget id …)]
|
||||
[trailing-dot? (raise-syntax-error 'dot "Found trailing dot" #'x)]
|
||||
[else #'(get id …)])))
|
||||
|
||||
|
||||
(define-syntax (new-#%top stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . x)
|
||||
(if (regexp-match #rx"\\." (symbol->string (syntax-e #'x)))
|
||||
#`(dot x)
|
||||
#'(#%top . x))])))
|
||||
#'(#%top . x))]))|#
|
||||
|
||||
(define-syntax (new-#%module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . body)
|
||||
#`(#%module-begin
|
||||
. #,(fold-syntax replace-dots
|
||||
#'body))]))
|
||||
|
||||
(define-for-syntax (replace-dots stx)
|
||||
(syntax-parse stx
|
||||
[x:id
|
||||
#:when (regexp-match #px"^.*\\..*[^.]$"
|
||||
(symbol->string (syntax-e #'x)))
|
||||
(let* ([str (symbol->string (syntax-e #'x))]
|
||||
[components (regexp-match* #px"([^.…]|\\.\\.+)+|…" str)]
|
||||
[unescaped (map (λ (m) (regexp-replace* #px"\\.(\\.+)" m "\\1"))
|
||||
components)]
|
||||
[identifiers (map (λ (u) (datum->syntax stx
|
||||
(string->symbol u)
|
||||
stx
|
||||
stx))
|
||||
unescaped)]
|
||||
[leading-dot? (regexp-match #px"^(\\.|…)" str)]
|
||||
[trailing-dot? (regexp-match #px"\\.$" str)])
|
||||
(define/with-syntax (id …) identifiers)
|
||||
(if leading-dot?
|
||||
(let* ([loc (update-source-location stx #:span 1)])
|
||||
(quasisyntax/loc stx (#,(datum->syntax stx 'λget loc stx) id …)))
|
||||
(if (= (length identifiers) 1)
|
||||
(quasisyntax/loc stx #,(car identifiers))
|
||||
(quasisyntax/loc stx
|
||||
(#,(datum->syntax stx 'get stx stx) id …)))))]
|
||||
[x:id
|
||||
#:when (regexp-match #px"\\.$" (symbol->string (syntax-e #'x)))
|
||||
(let* ([str (symbol->string (syntax-e #'x))]
|
||||
[unescaped (substring str 0 (sub1 (string-length str)))])
|
||||
(datum->syntax stx (string->symbol unescaped) stx stx))]
|
||||
[_ stx]))
|
||||
|
||||
(define-for-syntax (fold-syntax f e)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(let ([new-e (f e)])
|
||||
(if (eq? new-e e)
|
||||
(datum->syntax e (fold-syntax f (syntax-e e)) e e)
|
||||
new-e))]
|
||||
[(pair? e)
|
||||
(cons (fold-syntax f (car e))
|
||||
(fold-syntax f (cdr e)))]
|
||||
[(vector? e)
|
||||
(list->vector (fold-syntax f (vector->list e)))]
|
||||
[(box? e)
|
||||
(box (fold-syntax f (unbox e)))]
|
||||
[(prefab-struct-key e)
|
||||
=> (λ (k) (apply make-prefab-struct
|
||||
k
|
||||
(fold-syntax f (struct->list e))))]
|
||||
[else e])))
|
||||
|
||||
(require 'dotlang)
|
||||
(provide (all-from-out 'dotlang))
|
||||
|
||||
#;(module test (submod ".." dotlang)
|
||||
(require typed/rackunit)
|
||||
(let ((foo.bar 42))
|
||||
(check-equal? foo.bar 42))
|
||||
(check-equal? foo.bar '(dot "foo" "bar")))
|
||||
(module test (submod ".." dotlang)
|
||||
(require typed/rackunit
|
||||
"../lib/low.rkt"
|
||||
"graph4.lp2.rkt"
|
||||
(submod "graph3.lp2.rkt" test)
|
||||
"map4.rkt")
|
||||
|
||||
(let ((foo..bar 42))
|
||||
(check-equal?: foo..bar 42))
|
||||
|
||||
(check-equal?: 'foo.bar '(get foo bar))
|
||||
|
||||
;; Srcloc tests:
|
||||
;(let .a b) ;; Error on the first .
|
||||
;(let .a.b b) ;; Error on the first .
|
||||
;(let a.b b) ;; Error on the whole a.b
|
||||
|
||||
(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 'get 'b 'c))
|
||||
(check-equal?: '(a . b.c.d) (list 'a 'get 'b 'c 'd))
|
||||
(check-equal?: '(a.c . b) (cons (list 'get 'a 'c) 'b))
|
||||
(check-equal?: '(a.c.d . b) (cons (list 'get 'a 'c 'd) 'b))
|
||||
|
||||
(check-equal?: '.aa.bb..cc.d (list 'λget 'aa (slen 5 "bb.cc") 'd))
|
||||
(check-equal?: '…aa...bb..cc.d (list 'λget '… (slen 9 "aa..bb.cc") 'd))
|
||||
(check-equal?: '…aa.….bb..cc.d (list 'λget '… 'aa '… (slen 5 "bb.cc") 'd))
|
||||
(check-equal?: '.aa.….bb..cc.d (list 'λget 'aa '… (slen 5 "bb.cc") 'd))
|
||||
(check-equal?: '.aa.….bb.cc.d (list 'λget 'aa '… 'bb 'cc 'd))
|
||||
(check-equal?: '…aa.….bb.cc.d (list 'λget '… 'aa '… 'bb 'cc 'd))
|
||||
|
||||
(check-equal?: 'aa.bb..cc.d (list 'get 'aa (slen 5 "bb.cc") 'd))
|
||||
(check-equal?: 'aa...bb..cc.d (list 'get (slen 9 "aa..bb.cc") 'd))
|
||||
(check-equal?: 'aa…bb..cc.d (list 'get 'aa '… (slen 5 "bb.cc") 'd))
|
||||
(check-equal?: 'aa.….bb..cc.d (list 'get 'aa '… (slen 5 "bb.cc") 'd))
|
||||
(check-equal?: 'aa.….bb.cc.d (list 'get 'aa '… 'bb 'cc 'd))
|
||||
|
||||
(check-equal?: '… (slen 1 "…"))
|
||||
|
||||
#|
|
||||
(check-equal?: '…aa.…bb..cc.d) ;; TODO: should cause error
|
||||
(check-equal?: '…aa….bb..cc.d) ;; TODO: should cause error
|
||||
|#)
|
||||
|
|
|
|||
|
|
@ -602,8 +602,6 @@ are replaced by tagged indices:
|
|||
(vector-ref root/database 0))])
|
||||
(delay root/with-promises)))))))]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
@chunk[<module-main>
|
||||
(module main typed/racket
|
||||
(require (for-syntax syntax/parse
|
||||
|
|
@ -645,6 +643,8 @@ not match the one from @tc[typed/racket]
|
|||
(provide g)
|
||||
<use-example>)]
|
||||
|
||||
The whole file, finally:
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
<module-main>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require (submod "graph/test-map4-get.rkt" test))
|
||||
(require "__DEBUG_dotlang.rkt")
|
||||
(require (submod "graph/dotlang.rkt" test))
|
||||
|
||||
(require "type-expander/type-expander.lp2.rkt")
|
||||
(require "type-expander/multi-id.lp2.rkt")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user