commit 263a48521d068896e7363e861db123a76ccf6734
parent 72873d5d26bec71be300a073ce6909b71c8d9d47
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 22 Dec 2016 18:57:59 +0100
Working draft of a flexible implementation of (with tagged-instance [field val] …)
Diffstat:
| A | flexible-with-utils.rkt | | | 89 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | flexible-with.rkt | | | 201 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 290 insertions(+), 0 deletions(-)
diff --git a/flexible-with-utils.rkt b/flexible-with-utils.rkt
@@ -0,0 +1,88 @@
+#lang aful/unhygienic hyper-literate type-expander/lang
+
+@chunk[<*>
+ (require (for-syntax racket/base))
+
+ (provide (for-syntax to-bits
+ from-bits
+ floor-log2
+ ceiling-log2))
+
+ <to-bits>
+ <from-bits>
+ <floor-log2>
+ <ceiling-log2>
+
+ (module* test racket/base
+ (require (for-template (submod "..")))
+ (require rackunit)
+ <test-to-bits>
+ <test-from-bits>)]
+
+@CHUNK[<to-bits>
+ ; 1 => 1
+ ; 2 3 => 10 11
+ ;4 5 6 7 => 100 101 110 111
+ ;89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111
+
+ ; 1 => ""
+ ; 2 3 => 0 1
+ ;4 5 6 7 => 00 01 10 11
+ ;89 ab cd ef => 000 001 010 011 100 101 110 111
+
+ ; 0 => 0
+ ; 1 2 => 1 10
+ ;3 4 5 6 => 11 100 101 110
+ ;78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110
+
+
+ (define-for-syntax (to-bits n)
+ (reverse
+ (let loop ([n n])
+ (if (= n 0)
+ null
+ (let-values ([(q r) (quotient/remainder n 2)])
+ (cons (if (= r 1) #t #f) (loop q)))))))]
+
+@chunk[<test-to-bits>
+ (check-equal? (to-bits 0) '())
+ (check-equal? (to-bits 1) '(#t))
+ (check-equal? (to-bits 2) '(#t #f))
+ (check-equal? (to-bits 3) '(#t #t))
+ (check-equal? (to-bits 4) '(#t #f #f))
+ (check-equal? (to-bits 5) '(#t #f #t))
+ (check-equal? (to-bits 6) '(#t #t #f))
+ (check-equal? (to-bits 7) '(#t #t #t))
+ (check-equal? (to-bits 8) '(#t #f #f #f))
+ (check-equal? (to-bits 12) '(#t #t #f #f))
+ (check-equal? (to-bits 1024) '(#t #f #f #f #f #f #f #f #f #f #f))]
+
+@CHUNK[<from-bits>
+ (define-for-syntax (from-bits b)
+ (foldl (λ (bᵢ acc)
+ (+ (* acc 2) (if bᵢ 1 0)))
+ 0
+ b))]
+
+@chunk[<test-from-bits>
+ (check-equal? (from-bits '()) 0)
+ (check-equal? (from-bits '(#t)) 1)
+ (check-equal? (from-bits '(#t #f)) 2)
+ (check-equal? (from-bits '(#t #t)) 3)
+ (check-equal? (from-bits '(#t #f #f)) 4)
+ (check-equal? (from-bits '(#t #f #t)) 5)
+ (check-equal? (from-bits '(#t #t #f)) 6)
+ (check-equal? (from-bits '(#t #t #t)) 7)
+ (check-equal? (from-bits '(#t #f #f #f)) 8)
+ (check-equal? (from-bits '(#t #t #f #f)) 12)
+ (check-equal? (from-bits '(#t #f #f #f #f #f #f #f #f #f #f)) 1024)]
+
+@chunk[<floor-log2>
+ (define-for-syntax (floor-log2 n)
+ (if (<= n 1)
+ 0
+ (add1 (floor-log2 (quotient n 2)))))]
+
+@chunk[<ceiling-log2>
+ (define-for-syntax (ceiling-log2 n)
+ (floor-log2 (sub1 (* n 2))))]
+\ No newline at end of file
diff --git a/flexible-with.rkt b/flexible-with.rkt
@@ -0,0 +1,200 @@
+#lang aful/unhygienic hyper-literate type-expander/lang
+
+@chunk[<*>
+ (require (for-syntax (rename-in racket/base [... …])
+ syntax/stx
+ racket/syntax
+ racket/list
+ syntax/id-table
+ racket/sequence)
+ (for-meta 2 racket/base)
+ "flexible-with-utils.rkt")
+
+ <→τ>
+ <define-replace-in-tree>
+ <convert-fields>
+ <τ-with-fields>
+ <convert-from-struct>
+ <mk>
+ <utils>
+ <example>]
+
+@CHUNK[<→τ>
+ (define-for-syntax (→τ 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 τ*))]))]
+
+@CHUNK[<make-replace-in-tree-body>
+ (if (= i 1)
+ #'(λ () replacement)
+ (let* ([bits (to-bits i)]
+ [next (from-bits (cons #t (cddr bits)))]
+ [mod (cadr bits)])
+ (define/with-syntax next-id (vector-ref names (sub1 next)))
+ (if mod
+ #`(λ ()
+ (let ([tree (tree-thunk)])
+ (let ([left-subtree (car tree)]
+ [right-subtree (cdr tree)])
+ (cons left-subtree
+ ((next-id (λ () right-subtree) replacement))))))
+ #`(λ ()
+ (let ([tree (tree-thunk)])
+ (let ([left-subtree (car tree)]
+ [right-subtree (cdr tree)])
+ (cons ((next-id (λ () left-subtree) replacement))
+ right-subtree)))))))]
+
+@CHUNK[<define-replace-in-tree>
+ (define-for-syntax (define-replace-in-tree names τ* i depth)
+ (define/with-syntax name (vector-ref names (sub1 i)))
+ (define τ*-limited (take τ* depth))
+ #`(begin
+ (provide name)
+ (: name
+ (∀ (#,@τ*-limited T)
+ (→ (→ #,(→τ i #'Any τ*-limited))
+ T
+ (→ #,(→τ i #'T τ*-limited)))))
+ (define (name tree-thunk replacement)
+ #,<make-replace-in-tree-body>)))]
+
+@CHUNK[<convert-fields>
+ (define-for-syntax (convert-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[<τ-with-fields>
+ (define-for-syntax (τ-tree-with-fields fields all-fields)
+ (define/with-syntax (fl …) fields)
+ (define/with-syntax (field …) all-fields)
+ (let-values ([(all-fields depth-above offset i*-above names τ*)
+ (utils #'(field …))])
+ ;; Like in convert-from-struct
+ (define lookup
+ (make-free-id-table
+ (for/list ([n (in-syntax all-fields)]
+ [i (in-naturals)])
+ (cons n (+ i offset)))))
+ (define fields+indices
+ (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
+ #'(fl …))
+ <
+ #:key cdr))
+
+ (define up (* offset 2))
+
+ ;; Like in convert-fields, but with Pairof
+ (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
+ `(Pairof ,(f (* i 2))
+ ,(f (add1 (* i 2))))))))
+ (f 1)))]
+
+@CHUNK[<convert-from-struct>
+ (define-for-syntax (convert-from-struct
+ 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 lookup
+ (make-free-id-table
+ (for/list ([n (in-syntax all-fields)]
+ [i (in-naturals)])
+ (cons n (+ i offset)))))
+ (define fields+indices
+ (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
+ fields)
+ <
+ #:key cdr))
+ #`(begin
+ (: conv-name (∀ (field …)
+ (→ field …
+ (→ #,(τ-tree-with-fields #'(field …)
+ all-fields)))))
+ (define (conv-name field …)
+ (λ ()
+ #,(convert-fields (* offset 2) fields+indices)))))]
+
+@CHUNK[<mk>
+ (define-for-syntax (mk stx)
+ (syntax-case stx ()
+ [(bt-fields-id (field …) [struct struct-field …] …)
+ (let-values ([(all-fields depth-above offset i*-above names τ*)
+ (utils #'(field …))])
+ (define total-nb-functions (vector-length names))
+ #`(begin
+ (define-type-expander (bt-fields-id stx)
+ (syntax-case stx ()
+ [(_ . fs)
+ #`(∀ fs (→ #,(τ-tree-with-fields #'fs
+ #'(field …))))]))
+ #,@(map #λ(define-replace-in-tree names τ* % (floor-log2 %))
+ (range 1 (add1 total-nb-functions)))
+ #,@(map #λ(convert-from-struct
+ offset all-fields τ* %1 %2)
+ (syntax->list #'(struct …))
+ (syntax->list #'([struct-field …] …)))))]))]
+
+@CHUNK[<utils>
+ (define-for-syntax (utils stx)
+ (syntax-case stx ()
+ [(field …)
+ (let* ([all-fields #'(field …)]
+ [depth-above (ceiling-log2 (length (syntax->list #'(field …))))]
+ [offset (expt 2 depth-above)]
+ [i*-above (range 1 (expt 2 depth-above))]
+ [names (list->vector
+ (append (map (λ (i) (format-id #'here "-with-~a" i))
+ i*-above)
+ (stx-map (λ (f) (format-id f "with-~a" f))
+ #'(field …))))]
+ [τ* (map #λ(format-id #'here "τ~a" %) (range (add1 depth-above)))])
+ (values all-fields
+ depth-above
+ offset
+ i*-above
+ names
+ τ*))]))]
+@CHUNK[<example>
+ (define-syntax (gs stx)
+ (syntax-case stx ()
+ [(_ bt-fields-id nfields (f …) [struct struct-field …] …)
+ (let ()
+ (define/with-syntax (field …)
+ (append (syntax->list #'(f …))
+ (map (λ (_) (datum->syntax #'nfields (gensym 'g)))
+ (range (- (syntax-e #'nfields)
+ (length (syntax->list #'(f …))))))))
+ (mk #'(bt-fields-id (field …) [struct struct-field …] …)))]))
+
+ ;(gs 6)
+ (gs bt-fields
+ 16
+ (a b c)
+ [sab a b]
+ [sbc b c])
+
+ (ann (with-c (convert-sab 1 2) 'nine)
+ ((bt-fields a b c) One Positive-Byte 'nine))]
+\ No newline at end of file
