commit 5aae1459db05186b24e89e80daabfc981989b4c6
parent d7c41fabe6149d0206fc24aa0a38a84ce2c14604
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 22 Dec 2016 23:13:24 +0100
.
Diffstat:
| M | flexible-with.rkt | | | 99 | +++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------- |
1 file changed, 67 insertions(+), 32 deletions(-)
diff --git a/flexible-with.rkt b/flexible-with.rkt
@@ -10,20 +10,26 @@
(for-meta 2 racket/base)
"flexible-with-utils.rkt")
- <→τ>
+ <tree-type-with-replacement>
<define-replace-in-tree>
<convert-fields>
<τ-tree-with-fields>
- <convert-from-struct>
- <mk>
+ <define-struct→tree>
+ <define-trees>
<example>]
-@CHUNK[<→τ>
- (define-for-syntax (→τ n last τ*)
+@CHUNK[<tree-type-with-replacement>
+ (define-for-syntax (tree-type-with-replacement n last τ*)
(define-values (next mod) (quotient/remainder n 2))
(cond [(null? τ*) last]
- [(= mod 0) (→τ next #`(Pairof #,last #,(car τ*)) (cdr τ*))]
- [else (→τ next #`(Pairof #,(car τ*) #,last) (cdr τ*))]))]
+ [(= mod 0)
+ (tree-type-with-replacement next
+ #`(Pairof #,last #,(car τ*))
+ (cdr τ*))]
+ [else
+ (tree-type-with-replacement next
+ #`(Pairof #,(car τ*) #,last)
+ (cdr τ*))]))]
@CHUNK[<make-replace-in-tree-body>
(if (= i 1)
@@ -54,9 +60,9 @@
(provide name)
(: name
(∀ (#,@τ*-limited T)
- (→ (→ #,(→τ i #'Any τ*-limited))
+ (→ (→ #,(tree-type-with-replacement i #'Any τ*-limited))
T
- (→ #,(→τ i #'T τ*-limited)))))
+ (→ #,(tree-type-with-replacement i #'T τ*-limited)))))
(define (name tree-thunk replacement)
#,<make-replace-in-tree-body>)))]
@@ -77,6 +83,23 @@
;(displayln (syntax->datum #`#,(f 1)))
(f 1))]
+@CHUNK[<convert-back-fields>
+ (define-for-syntax (convert-back-fields up fields+indices)
+ ;(displayln fields+indices)
+ (define (f i)
+ ;(displayln (list i '/ up (syntax->datum #`#,fields+indices)))
+ (if (and (pair? fields+indices) (= i (cdar fields+indices)))
+ (begin0
+ (caar fields+indices)
+ (set! fields+indices (cdr fields+indices)))
+ (if (>= (* i 2) up) ;; DEPTH
+ ''MISSING
+ (begin
+ `(cons ,(f (* i 2))
+ ,(f (add1 (* i 2))))))))
+ ;(displayln (syntax->datum #`#,(f 1)))
+ (f 1))]
+
@CHUNK[<τ-tree-with-fields>
(define-for-syntax (τ-tree-with-fields struct-fields fields)
(define/with-syntax (struct-field …) struct-fields)
@@ -110,12 +133,14 @@
,(f (add1 (* i 2))))))))
(f 1))]
-@CHUNK[<convert-from-struct>
- (define-for-syntax (convert-from-struct
- offset all-fields τ* struct-name fields)
+@CHUNK[<define-struct→tree>
+ (define-for-syntax (define-struct→tree
+ offset all-fields τ* struct-name fields)
(define/with-syntax (field …) fields)
- (define/with-syntax conv-name
- (format-id struct-name "convert-~a" struct-name))
+ (define/with-syntax fields→tree-name
+ (format-id struct-name "~a→tree" struct-name))
+ (define/with-syntax tree→fields-name
+ (format-id struct-name "tree→~a" struct-name))
(define lookup
(make-free-id-table
(for/list ([n (in-syntax all-fields)]
@@ -127,20 +152,31 @@
<
#:key cdr))
#`(begin
- (: conv-name (∀ (field …)
- (→ field …
- (→ #,(τ-tree-with-fields #'(field …)
- all-fields)))))
- (define (conv-name field …)
+ (: fields→tree-name (∀ (field …)
+ (→ field …
+ (→ #,(τ-tree-with-fields #'(field …)
+ all-fields)))))
+ (define (fields→tree-name field …)
(λ ()
- #,(convert-fields (* offset 2) fields+indices)))))]
+ #,(convert-fields (* offset 2) fields+indices)))
+
+ (: tree→fields-name (∀ (field …)
+ (→ (→ #,(τ-tree-with-fields #'(field …)
+ all-fields))
+ (Values field …))))
+ (define (tree→fields-name tree-thunk)
+ (define tree (tree-thunk))
+ (values (error "Not implmtd yet" 'field) …)
+ #;#,(convert-fields (* offset 2) fields+indices))))]
-@CHUNK[<mk>
- (define-for-syntax (mk stx)
+@CHUNK[<define-trees>
+ (define-for-syntax (define-trees stx)
(syntax-case stx ()
[(bt-fields-id (field …) [struct struct-field …] …)
(let ()
<utils>
+ (define ∀-types (map #λ(format-id #'here "τ~a" %)
+ (range (add1 depth-above))))
(define total-nb-functions (vector-length names))
#`(begin
(define-type-expander (bt-fields-id stx)
@@ -148,10 +184,10 @@
[(_ . fs)
#`(∀ fs (→ #,(τ-tree-with-fields #'fs
#'(field …))))]))
- #,@(map #λ(define-replace-in-tree names τ* % (floor-log2 %))
+ #,@(map #λ(define-replace-in-tree names ∀-types % (floor-log2 %))
(range 1 (add1 total-nb-functions)))
- #,@(map #λ(convert-from-struct
- offset all-fields τ* %1 %2)
+ #,@(map #λ(define-struct→tree
+ offset all-fields ∀-types %1 %2)
(syntax->list #'(struct …))
(syntax->list #'([struct-field …] …)))))]))]
@@ -160,12 +196,11 @@
(define depth-above (ceiling-log2 (length (syntax->list #'(field …)))))
(define offset (expt 2 depth-above))
(define i*-above (range 1 (expt 2 depth-above)))
- (define τ* (map #λ(format-id #'here "τ~a" %) (range (add1 depth-above))))
(define names (list->vector
- (append (map (λ (i) (format-id #'here "-with-~a" i))
- i*-above)
- (stx-map (λ (f) (format-id f "with-~a" f))
- #'(field …)))))]
+ (append (map (λ (i) (format-id #'here "-with-~a" i))
+ i*-above)
+ (stx-map (λ (f) (format-id f "with-~a" f))
+ #'(field …)))))]
@CHUNK[<example>
(define-syntax (gs stx)
(syntax-case stx ()
@@ -176,7 +211,7 @@
(map (λ (_) (datum->syntax #'nfields (gensym 'g)))
(range (- (syntax-e #'nfields)
(length (syntax->list #'(f …))))))))
- (mk #'(bt-fields-id (field …) [struct struct-field …] …)))]))
+ (define-trees #'(bt-fields-id (field …) [struct struct-field …] …)))]))
;(gs 6)
(gs bt-fields
@@ -185,5 +220,5 @@
[sab a b]
[sbc b c])
- (ann (with-c (convert-sab 1 2) 'nine)
+ (ann (with-c (sab→tree 1 2) 'nine)
((bt-fields a b c) One Positive-Byte 'nine))]
\ No newline at end of file
