Working draft of a flexible implementation of (with tagged-instance [field val] …)
This commit is contained in:
Georges Dupéron
parent
72873d5d26
commit
263a48521d
88
flexible-with-utils.rkt
Normal file
88
flexible-with-utils.rkt
Normal file
|
|
@ -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))))]
|
||||||
200
flexible-with.rkt
Normal file
200
flexible-with.rkt
Normal file
|
|
@ -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))]
|
||||||
Loading…
Reference in New Issue
Block a user