From 263a48521d068896e7363e861db123a76ccf6734 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 22 Dec 2016 18:57:59 +0100 Subject: [PATCH] =?UTF-8?q?Working=20draft=20of=20a=20flexible=20implement?= =?UTF-8?q?ation=20of=20(with=20tagged-instance=20[field=20val]=20?= =?UTF-8?q?=E2=80=A6)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- flexible-with-utils.rkt | 88 ++++++++++++++++++ flexible-with.rkt | 200 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 288 insertions(+) create mode 100644 flexible-with-utils.rkt create mode 100644 flexible-with.rkt diff --git a/flexible-with-utils.rkt b/flexible-with-utils.rkt new file mode 100644 index 0000000..3da7c0e --- /dev/null +++ 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)) + + + + + + + (module* test racket/base + (require (for-template (submod ".."))) + (require rackunit) + + )] + +@CHUNK[ + ; 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[ + (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[ + (define-for-syntax (from-bits b) + (foldl (λ (bᵢ acc) + (+ (* acc 2) (if bᵢ 1 0))) + 0 + b))] + +@chunk[ + (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[ + (define-for-syntax (floor-log2 n) + (if (<= n 1) + 0 + (add1 (floor-log2 (quotient n 2)))))] + +@chunk[ + (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 new file mode 100644 index 0000000..2083784 --- /dev/null +++ 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") + + <→τ> + + + <τ-with-fields> + + + + ] + +@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[ + (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-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) + #,)))] + +@CHUNK[ + (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[ + (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[ + (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[ + (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[ + (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