From d6c6f865446ec5713d90c97f174d91046faf13e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 22 Jan 2016 19:29:28 +0100 Subject: [PATCH] =?UTF-8?q?Fixes=20FB=20case=2079=20(=E2=80=A6=20as=20punc?= =?UTF-8?q?tuation),=20case=2044=20(test=20for=20=E2=80=A6=20and=20(a=20.?= =?UTF-8?q?=20b)),=20case=2084=20(tests),=20and=20case=2082=20(replace=20i?= =?UTF-8?q?n-depth,=20so=20that=20repalcements=20are=20done=20in=20macros?= =?UTF-8?q?=20too).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- graph-lib/__DEBUG_dotlang.rkt | 27 ------- graph-lib/graph/dotlang.rkt | 133 ++++++++++++++++++++++++++++++--- graph-lib/graph/graph3.lp2.rkt | 4 +- graph-lib/main.rkt | 2 +- 4 files changed, 127 insertions(+), 39 deletions(-) delete mode 100644 graph-lib/__DEBUG_dotlang.rkt diff --git a/graph-lib/__DEBUG_dotlang.rkt b/graph-lib/__DEBUG_dotlang.rkt deleted file mode 100644 index c38000a2..00000000 --- a/graph-lib/__DEBUG_dotlang.rkt +++ /dev/null @@ -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) \ No newline at end of file diff --git a/graph-lib/graph/dotlang.rkt b/graph-lib/graph/dotlang.rkt index cd564383..dc1473fe 100644 --- a/graph-lib/graph/dotlang.rkt +++ b/graph-lib/graph/dotlang.rkt @@ -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 + |#) diff --git a/graph-lib/graph/graph3.lp2.rkt b/graph-lib/graph/graph3.lp2.rkt index 65092aab..6e4e19b5 100644 --- a/graph-lib/graph/graph3.lp2.rkt +++ b/graph-lib/graph/graph3.lp2.rkt @@ -602,8 +602,6 @@ are replaced by tagged indices: (vector-ref root/database 0))]) (delay root/with-promises)))))))] -@section{Conclusion} - @chunk[ (module main typed/racket (require (for-syntax syntax/parse @@ -645,6 +643,8 @@ not match the one from @tc[typed/racket] (provide g) )] +The whole file, finally: + @chunk[<*> (begin diff --git a/graph-lib/main.rkt b/graph-lib/main.rkt index 86e61baf..7c772652 100644 --- a/graph-lib/main.rkt +++ b/graph-lib/main.rkt @@ -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")