commit 95c156717cbc45cd115114d69fb5862e634e71e2
parent 4c84b1625d7d3b977eb9f81ab130c3da1a1c31b0
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Mon, 3 Oct 2016 03:25:20 +0200
First draft for define-fold, all tests pass.
Diffstat:
3 files changed, 183 insertions(+), 25 deletions(-)
diff --git a/free-identifier-tree-equal.rkt 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
@@ -3,20 +3,62 @@
(require "../traversal.hl.rkt"
"ck.rkt")
+(define-type Foo (Listof String))
+
(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 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₂ (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
@@ -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-fold-prepare>
- (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)
+ <type-cases>)]
+
+@chunk[<type-cases>
+ [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[<type-cases>
+ [(~or Null (List))
+ => Null
+ (values v acc)]]
+
+@chunk[<type-cases>
+ [(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[<type-cases>
+ [(Listof X)
+ => (Listof (te Tᵢ …))
+ (foldl-map (fe . args) acc v)
+ (define-fold fe te X type-to-replaceᵢ …)]]
+
+@chunk[<type-cases>
+ [(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[<type-cases>
+ [(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[<type-cases>
+ [else-T
+ => else-T
+ (values v acc)]]
+
+where @racket[foldl-map] is defined as:
+
+@chunk[<foldl-map>
+ (: 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[<type-cases-macro>
+ (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[<define-fold-result>
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 <type-cases-macro>)
+ <foldl-map>
<define-fold>]
\ No newline at end of file
