suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

Working draft of a flexible implementation of (with tagged-instance [field val] …)

Browse Source
This commit is contained in:
Georges Dupéron 2016-12-22 18:57:59 +01:00
parent 72873d5d26
commit 263a48521d
2 changed files with 288 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
flexible-with-utils.rkt Normal file
View 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
View 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))]