From 48625734536e0db8264d85b7356d08e754f1a36d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 3 Oct 2016 23:55:26 +0200 Subject: [PATCH] Preliminary support for tagged structures, early draft for unions --- dispatch-union.rkt | 24 +++++++ test/adt-pre-declarations.rkt | 2 + test/ck.rkt | 4 +- test/test-traversal-2.rkt | 21 ++++++ traversal.hl.rkt | 124 ++++++++++++++++++++++++++++------ 5 files changed, 151 insertions(+), 24 deletions(-) create mode 100644 dispatch-union.rkt create mode 100644 test/adt-pre-declarations.rkt create mode 100644 test/test-traversal-2.rkt diff --git a/dispatch-union.rkt b/dispatch-union.rkt new file mode 100644 index 0000000..e32fcf8 --- /dev/null +++ b/dispatch-union.rkt @@ -0,0 +1,24 @@ +#lang typed/racket + +(require phc-toolkit + (for-syntax racket/base + phc-toolkit/untyped + racket/syntax + syntax/parse + syntax/parse/experimental/template + type-expander/expander + "free-identifier-tree-equal.rkt") + (for-meta 2 racket/base) + (for-meta 2 phc-toolkit/untyped) + (for-meta 2 syntax/parse)) + +(define-syntax/parse (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] …) + [X v result] …) + (stx-map + (λ (X v result) + (cond + [(meta-struct? X) #`[((struct-predicate #,X) #,v) #,result]] + [else (raise-syntax-error 'graph "Unhandled union type" #'X)])) + #'(X …) + #'(v …) + #'(result …))) \ No newline at end of file diff --git a/test/adt-pre-declarations.rkt b/test/adt-pre-declarations.rkt new file mode 100644 index 0000000..5d0957d --- /dev/null +++ b/test/adt-pre-declarations.rkt @@ -0,0 +1,2 @@ +#lang s-exp phc-adt/declarations +(remembered! tagged-structure (tg a b)) diff --git a/test/ck.rkt b/test/ck.rkt index f8b958d..dc7bb7d 100644 --- a/test/ck.rkt +++ b/test/ck.rkt @@ -10,11 +10,11 @@ (define-syntax check-equal?-values: (syntax-parser - [(_ actual {~maybe :colon type} expected ...) + [(_ actual {~maybe :colon type:type-expand!} expected ...) (quasisyntax/top-loc this-syntax (check-equal?: (call-with-values (ann (λ () actual) (-> #,(if (attribute type) - #'type + #'type.expanded #'AnyValues))) (λ l l)) (list expected ...)))])) diff --git a/test/test-traversal-2.rkt b/test/test-traversal-2.rkt new file mode 100644 index 0000000..b50cd6a --- /dev/null +++ b/test/test-traversal-2.rkt @@ -0,0 +1,21 @@ +#lang typed/racket + +(require "../traversal.hl.rkt" + type-expander + phc-adt + "ck.rkt") +(adt-init) + +#;(define-type Foo (Listof String)) + +(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String) + +(define (string->symbol+acc [x : String] [acc : Integer]) + (values (string->symbol x) (add1 acc))) + +(check-equal?-values: + ((f₁ string? string->symbol+acc) (tagged tg [a "abc"] [b #f]) 0) + : (Values (tagged tg [a Symbol] [b Boolean]) Integer) + (tagged tg [a 'abc] [b #f]) 1) + + diff --git a/traversal.hl.rkt b/traversal.hl.rkt index 3ec99d3..83cbb8b 100644 --- a/traversal.hl.rkt +++ b/traversal.hl.rkt @@ -145,8 +145,10 @@ way up, so that a simple identity function can be applied in these cases. @chunk[ (type-cases - (whole-type => _the-type _the-code the-defs …) - #:literals (Null Pairof Listof List Vectorof Vector) + (whole-type #:to _the-type + #:using _the-code + #:with-defintitions the-defs …) + #:literals (Null Pairof Listof List Vectorof Vector U tagged) )] @chunk[ @@ -155,49 +157,120 @@ way up, so that a simple identity function can be applied in these cases. (syntax->list #'([type-to-replaceᵢ updateᵢ _Tᵢ] …))) #:when (attribute info) #:with (_ update T) #'info - => T + + #:to + T + + #:using (update v acc)]] @chunk[ [(~or Null (List)) - => Null + + #:to + Null + + #:using (values v acc)]] @chunk[ [(Pairof X Y) - => (Pairof (tx _Tᵢ …) (ty _Tᵢ …)) + + #:to + (Pairof (tx _Tᵢ …) (ty _Tᵢ …)) + + #:using (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)) + + #:with-defintitions (define-fold fx tx X type-to-replaceᵢ …) (define-fold fy ty Y type-to-replaceᵢ …)]] @chunk[ [(Listof X) - => (Listof (te _Tᵢ …)) + + #:to + (Listof (te _Tᵢ …)) + + #:using (foldl-map (fe . _args) acc v) + + #:with-defintitions (define-fold fe te X type-to-replaceᵢ …)]] @chunk[ [(Vectorof X) - => (Vectorof (te _Tᵢ …)) + + #:to + (Vectorof (te _Tᵢ …)) + + #:using (vector->immutable-vector (list->vector (foldl-map (fe . _args) acc (vector->list v)))) + + #:with-defintitions (define-fold fe te X type-to-replaceᵢ …)]] @chunk[ - [(List X Y ...) - => (Pairof (tx _Tᵢ …) (ty* _Tᵢ …)) + [(List X Y …) + + #:to + (Pairof (tx _Tᵢ …) (ty* _Tᵢ …)) + + #:using (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*)) + + #:with-defintitions (define-fold fx tx X type-to-replaceᵢ …) - (define-fold fy* ty* (List Y ...) type-to-replaceᵢ …)]] + (define-fold fy* ty* (List Y …) type-to-replaceᵢ …)]] + +@chunk[ + [(U X …) + + #:to + (U (tx _Tᵢ …)) + + #:using + (dispatch-union ([type-to-replaceᵢ Aᵢ predicateᵢ] + …) + [X v ((fx . _args) v acc)] + …) + + #:with-defintitions + (define-fold fx tx X type-to-replaceᵢ …) + …]] + +@chunk[ + [(tagged _name [_field (~optional :colon) _X] … + {~do (define-temp-ids "_fx" (_X …))} + {~do (define-temp-ids "_tx" (_X …))} + {~do (define-temp-ids "_result" (_X …))}) + + #:to + (tagged _name [_field : (_tx _Tᵢ …)] …) + + #:using + (let*-values ([(_result acc) ((_fx . _args) (uniform-get v _field) acc)] + …) + (values (tagged _name [_field _result] …) + acc)) + + #:with-defintitions + (define-fold _fx _tx _X type-to-replaceᵢ …) + …]] @chunk[ [else-T - => else-T + + #:to + else-T + + #:using (values v acc)]] where @racket[foldl-map] is defined as: @@ -219,17 +292,22 @@ where @racket[foldl-map] is defined as: @chunk[ (define-syntax type-cases (syntax-parser - #:literals (=>) - [(_ (whole-type => the-type the-code the-defs (~literal …)) + [(_ (whole-type #:to the-type + #:using the-code + #:with-defintitions the-defs (~literal …)) #:literals (lit …) - (Pat opts … => transform-type transform-code transform-defs …) + (Pat opts … + #:to transform-type + #:using transform-code + (~optional (~seq #:with-defintitions transform-defs …) + #:defaults ([(transform-defs 1) (list)]))) …) #'(define/with-syntax (the-type the-code the-defs (… …)) (syntax-parse #'whole-type #:literals (lit …) [Pat opts … (template - (transform-type transform-code transform-defs …))] + (transform-type transform-code transform-defs …))] …))]))] @chunk[ @@ -238,13 +316,13 @@ where @racket[foldl-map] is defined as: (define-type (_type-name _Tᵢ …) _the-type) (: _function-name (∀ (_Aᵢ … _Bᵢ … Acc) - (→ (?@ (→ Any Boolean : _Aᵢ) - (→ _Aᵢ Acc (Values _Bᵢ Acc))) - … - (→ (_type-name _Aᵢ …) - Acc - (Values (_type-name _Bᵢ …) - Acc))))) + (→ (?@ (→ Any Boolean : _Aᵢ) + (→ _Aᵢ Acc (Values _Bᵢ Acc))) + … + (→ (_type-name _Aᵢ …) + Acc + (Values (_type-name _Bᵢ …) + Acc))))) (define ((_function-name . _args) v acc) _the-code)] @@ -252,6 +330,8 @@ where @racket[foldl-map] is defined as: @chunk[<*> (require phc-toolkit + type-expander + phc-adt (for-syntax racket/base phc-toolkit/untyped racket/syntax