From 95c156717cbc45cd115114d69fb5862e634e71e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 3 Oct 2016 03:25:20 +0200 Subject: [PATCH] First draft for define-fold, all tests pass. --- free-identifier-tree-equal.rkt | 29 +++++++++ test/test-traversal-1.rkt | 62 +++++++++++++++--- traversal.hl.rkt | 115 ++++++++++++++++++++++++++++----- 3 files changed, 181 insertions(+), 25 deletions(-) create mode 100644 free-identifier-tree-equal.rkt diff --git a/free-identifier-tree-equal.rkt b/free-identifier-tree-equal.rkt new file mode 100644 index 0000000..b9a16ee --- /dev/null +++ b/free-identifier-tree-equal.rkt @@ -0,0 +1,29 @@ +#lang racket + +(require racket/struct) + +(provide free-identifier-tree=?) + +(define (free-identifier-tree=? a b) + (define rec=? free-identifier-tree=?) + (cond + [(identifier? a) (and (identifier? b) + (free-identifier=? a b))] + [(syntax? a) (and (syntax? b) + (rec=? (syntax-e a) + (syntax-e b)))] + [(pair? a) (and (pair? b) + (rec=? (car a) (car b)) + (rec=? (cdr a) (cdr b)))] + [(vector? a) (and (vector? b) + (rec=? (vector->list a) + (vector->list b)))] + [(box? a) (and (box? b) + (rec=? (unbox a) + (unbox b)))] + [(prefab-struct-key a) + => (λ (a-key) + (let ([b-key (prefab-struct-key b)]) + (and (equal? a-key b-key) + (rec=? (struct->list a) + (struct->list b)))))])) \ No newline at end of file diff --git a/test/test-traversal-1.rkt b/test/test-traversal-1.rkt index fe8b4bd..bc0216f 100644 --- a/test/test-traversal-1.rkt +++ b/test/test-traversal-1.rkt @@ -3,20 +3,62 @@ (require "../traversal.hl.rkt" "ck.rkt") -(define-fold f₁ t₁ Null String) -;(define-fold f₂ t₂ (Pairof Null Null) String) -;(define-fold f₃ t₃ String String) -;(define-fold f₄ t₄ (Pairof Null String) String) +(define-type Foo (Listof String)) -(define f₁-string->symbol - (f₁ string? - (λ ([x : String] [acc : Integer]) - (values (string->symbol x) acc)))) -(check-equal?-values: (f₁-string->symbol '() 0) +(define-fold f₁ t₁ Null String) +(define-fold f₂ t₂ (Pairof Null Null) String) +(define-fold f₃ t₃ String String) +(define-fold f₄ t₄ (Pairof Null String) String) +(define-fold f₅ t₅ (Listof Null) String) +(define-fold f₆ t₆ (List Null (Pairof Null Null) Null) String) +(define-fold f₇ t₇ (Listof String) String) +(define-fold f₈ t₈ (List String Foo (Listof String)) String) + +(define (string->symbol+acc [x : String] [acc : Integer]) + (values (string->symbol x) (add1 acc))) + +(check-equal?-values: ((f₁ string? string->symbol+acc) '() 0) '() 0) -(check-equal?-values: (f₁-string->symbol '() 0) +(check-equal?-values: ((f₁ string? string->symbol+acc) '() 0) : (Values Null Integer) '() 0) +(check-equal?-values: ((f₂ string? string->symbol+acc) '(() . ()) 0) + : (Values (Pairof Null Null) Integer) + '(() . ()) 0) +(check-equal?-values: ((f₃ string? string->symbol+acc) "abc" 0) + : (Values Symbol Integer) + 'abc 1) + +(check-equal?-values: ((f₄ string? string->symbol+acc) '(() . "def") 0) + : (Values (Pairof Null Symbol) Integer) + '(() . def) 1) + +(check-equal?-values: ((f₅ string? string->symbol+acc) '(() () () ()) 0) + : (Values (Listof Null) Integer) + '(() () () ()) 0) + +(check-equal?-values: ((f₅ string? string->symbol+acc) '(()) 0) + : (Values (Listof Null) Integer) + '(()) 0) + +(check-equal?-values: ((f₅ string? string->symbol+acc) '() 0) + : (Values (Listof Null) Integer) + '() 0) + +(check-equal?-values: ((f₆ string? string->symbol+acc) '(() (() . ()) ()) 0) + : (Values (List Null (Pairof Null Null) Null) Integer) + '(() (() . ()) ()) 0) + +(check-equal?-values: ((f₇ string? string->symbol+acc) '("abc" "def" "ghi") 0) + : (Values (Listof Symbol) Integer) + '(abc def ghi) 3) + +(check-equal?-values: ((f₈ string? string->symbol+acc) '("abc" ("def" "ghi") + ("jkl" "mno")) + 0) + : (Values (List Symbol (Listof String) (Listof Symbol)) + Integer) + '(abc ("def" "ghi") (jkl mno)) 3) \ No newline at end of file diff --git a/traversal.hl.rkt b/traversal.hl.rkt index dd76e4a..5713ef3 100644 --- a/traversal.hl.rkt +++ b/traversal.hl.rkt @@ -139,19 +139,98 @@ way up, so that a simple identity function can be applied in these cases. (define-temp-ids "Aᵢ" (type-to-replaceᵢ …)) (define-temp-ids "Bᵢ" (type-to-replaceᵢ …)) (define-temp-ids "predicateᵢ" (type-to-replaceᵢ …)) - (define-temp-ids "updateᵢ" (type-to-replaceᵢ …))] + (define-temp-ids "updateᵢ" (type-to-replaceᵢ …)) + + (define/with-syntax args (template ({?@ predicateᵢ updateᵢ} …)))] @chunk[ - (define/with-syntax (the-type the-code the-defs …) - (syntax-parse #'whole-type - #:literals (Null Pairof Listof List Vectorof Vector) - [Null #'(Null (values v acc))] - [(Pairof X Y) - #'(Null - (values v acc) - (define-fold fx tx X type-to-replaceᵢ …) - (define-fold fy ty Y type-to-replaceᵢ …))] - [#t #'((Pairof Any Any) (void))]))] + (type-cases + (whole-type => the-type the-code the-defs …) + #:literals (Null Pairof Listof List Vectorof Vector) + )] + +@chunk[ + [t + #:with info (findf (λ (r) (free-identifier-tree=? #'t (stx-car r))) + (syntax->list #'([type-to-replaceᵢ updateᵢ Tᵢ] …))) + #:when (attribute info) + #:with (_ update T) #'info + => T + (update v acc)]] + +@chunk[ + [(~or Null (List)) + => Null + (values v acc)]] + +@chunk[ + [(Pairof X Y) + => (Pairof (tx Tᵢ …) (ty Tᵢ …)) + (let*-values ([(result-x acc-x) ((fx . args) (car v) acc)] + [(result-y acc-y) ((fy . args) (cdr v) acc-x)]) + (values (cons result-x result-y) acc-y)) + (define-fold fx tx X type-to-replaceᵢ …) + (define-fold fy ty Y type-to-replaceᵢ …)]] + +@chunk[ + [(Listof X) + => (Listof (te Tᵢ …)) + (foldl-map (fe . args) acc v) + (define-fold fe te X type-to-replaceᵢ …)]] + +@chunk[ + [(Vectorof X) + => (Vectorof (te Tᵢ …)) + (vector->immutable-vector + (list->vector + (foldl-map (fe . args) acc (vector->list v)))) + (define-fold fe te X type-to-replaceᵢ …)]] + +@chunk[ + [(List X Y ...) + => (Pairof (tx Tᵢ …) (ty* Tᵢ …)) + (let*-values ([(result-x acc-x) ((fx . args) (car v) acc)] + [(result-y* acc-y*) ((fy* . args) (cdr v) acc-x)]) + (values (cons result-x result-y*) acc-y*)) + (define-fold fx tx X type-to-replaceᵢ …) + (define-fold fy* ty* (List Y ...) type-to-replaceᵢ …)]] + +@chunk[ + [else-T + => else-T + (values v acc)]] + +where @racket[foldl-map] is defined as: + +@chunk[ + (: foldl-map (∀ (A B Acc) (→ (→ A Acc (Values B Acc)) + Acc + (Listof A) + (Values (Listof B) Acc)))) + (define (foldl-map f acc l) + (if (null? l) + (values l + acc) + (let*-values ([(v a) (f (car l) acc)] + [(ll aa) (foldl-map f a (cdr l))]) + (values (cons v ll) + aa))))] + +@chunk[ + (define-syntax type-cases + (syntax-parser + #:literals (=>) + [(_ (whole-type => the-type the-code the-defs (~literal …)) + #:literals (lit …) + (Pat opts … => transform-type transform-code transform-defs …) + …) + #'(define/with-syntax (the-type the-code the-defs (… …)) + (syntax-parse #'whole-type + #:literals (lit …) + [Pat opts … + (template + (transform-type transform-code transform-defs …))] + …))]))] @chunk[ the-defs … @@ -159,14 +238,14 @@ way up, so that a simple identity function can be applied in these cases. (define-type (type-name Tᵢ …) the-type) (: function-name (∀ (Aᵢ … Bᵢ … Acc) - (→ (?@ (→ Any Boolean : Aᵢ) - (→ Aᵢ Acc (Values Bᵢ Acc))) + (→ {?@ (→ Any Boolean : Aᵢ) + (→ Aᵢ Acc (Values Bᵢ Acc))} … (→ (type-name Aᵢ …) Acc (Values (type-name Bᵢ …) Acc))))) - (define ((function-name (?@ predicateᵢ updateᵢ) …) v acc) + (define ((function-name . args) v acc) the-code)] @section{Putting it all together} @@ -178,7 +257,13 @@ way up, so that a simple identity function can be applied in these cases. racket/syntax syntax/parse syntax/parse/experimental/template - type-expander/expander)) + type-expander/expander + "free-identifier-tree-equal.rkt") + (for-meta 2 racket/base) + (for-meta 2 phc-toolkit/untyped) + (for-meta 2 syntax/parse)) (provide define-fold) + (begin-for-syntax ) + ] \ No newline at end of file