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

Cleanup

Browse Source
This commit is contained in:
Georges Dupéron 2016-11-10 17:57:12 +01:00
parent 4b9d7cba22
commit 3458175b0c
4 changed files with 44 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
test/test-traversal-1.rkt
View File

@ -1,6 +1,6 @@
#lang type-expander #lang type-expander
(require "traversal-util.rkt" ;"../traversal.hl.rkt" (require "traversal-util.rkt"
"ck.rkt") "ck.rkt")
(define-type Foo (Listof String)) (define-type Foo (Listof String))

2
test/test-traversal-2.rkt
View File

@ -1,6 +1,6 @@
#lang typed/racket #lang typed/racket
(require "traversal-util.rkt" ;"../traversal.hl.rkt" (require "traversal-util.rkt"
type-expander type-expander
phc-adt phc-adt
"ck.rkt" "ck.rkt"

2
test/traversal-util.rkt
View File

@ -1,6 +1,6 @@
#lang typed/racket #lang typed/racket
(require (for-syntax syntax/parse (require (for-syntax syntax/parse
syntax/parse/experimental/template backport-template-pr1514/experimental/template
type-expander/expander) type-expander/expander)
"../traversal.hl.rkt") "../traversal.hl.rkt")

83
traversal.hl.rkt
View File

@ -149,16 +149,22 @@ not expressed syntactically using the @racket[Foo] identifier.
@; cases. @; cases.
@CHUNK[<define-fold> @CHUNK[<api>
(begin-for-syntax (define-template-metafunction (replace-in-type stx)
(define-template-metafunction (replace-in-type stx) (syntax-case stx ()
(syntax-case stx () [(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …)
[(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …) #`(#,(syntax-local-template-metafunction-introduce
#`(#,(syntax-local-template-metafunction-introduce (fold-τ #'(_whole-type _type-to-replaceᵢ …))) _Tᵢ …)]))]
(fold-type #'(_whole-type _type-to-replaceᵢ …))) _Tᵢ …)])))]
@CHUNK[<define-fold> @CHUNK[<api>
(define-for-syntax fold-type (define-template-metafunction (∀-replace-in-type stx)
(syntax-case stx ()
[(_ _whole-type _type-to-replaceᵢ …)
(syntax-local-template-metafunction-introduce
(fold-τ #'(_whole-type _type-to-replaceᵢ …)))]))]
@CHUNK[<fold-τ>
(define fold-τ
(syntax-parser (syntax-parser
[(_whole-type:type _type-to-replaceᵢ:type …) [(_whole-type:type _type-to-replaceᵢ:type …)
#:with rec-args #'([_type-to-replaceᵢ _Tᵢ] …) #:with rec-args #'([_type-to-replaceᵢ _Tᵢ] …)
@ -180,7 +186,7 @@ not expressed syntactically using the @racket[Foo] identifier.
(define-syntax-rule (cached [base cache defs key] . body) (define-syntax-rule (cached [base cache defs key] . body)
(begin (begin
(unless (and cache defs) (unless (and cache defs)
(error "fold-type and fold-f must be called within with-folds")) (error "fold-τ and fold-f must be called within with-folds"))
(if (dict-has-key? cache key) (if (dict-has-key? cache key)
(dict-ref cache key) (dict-ref cache key)
(let ([base #`#,(gensym 'base)]) (let ([base #`#,(gensym 'base)])
@ -189,17 +195,23 @@ not expressed syntactically using the @racket[Foo] identifier.
(set-box! defs `([,base . ,result] . ,(unbox defs))) (set-box! defs `([,base . ,result] . ,(unbox defs)))
base))))))] base))))))]
@CHUNK[<define-fold> @CHUNK[<api>
(begin-for-syntax (define-template-metafunction (replace-in-instance stx)
(define-template-metafunction (replace-in-instance stx) (syntax-case stx ()
(syntax-case stx () [(_ _whole-type [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
[(_ _whole-type [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) #`(#,(syntax-local-template-metafunction-introduce
#`(#,(syntax-local-template-metafunction-introduce (fold-f #'(_whole-type _type-to-replaceᵢ …)))
(fold-f #'(_whole-type _type-to-replaceᵢ …))) {?@ _predicateᵢ _updateᵢ} …)]))]
{?@ _predicateᵢ _updateᵢ} …)])))]
@CHUNK[<api>
(define-template-metafunction (λ-replace-in-instance stx)
(syntax-case stx ()
[(_ _whole-type _type-to-replaceᵢ …)
(syntax-local-introduce
(fold-f #'(_whole-type _type-to-replaceᵢ …)))]))]
@CHUNK[<define-fold> @CHUNK[<fold-f>
(define-for-syntax fold-f (define fold-f
(syntax-parser (syntax-parser
[(_whole-type:type _type-to-replaceᵢ:type …) [(_whole-type:type _type-to-replaceᵢ:type …)
#:with rec-args #'([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) #:with rec-args #'([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …)
@ -333,23 +345,6 @@ not expressed syntactically using the @racket[Foo] identifier.
#'(values v acc)]] #'(values v acc)]]
@CHUNK[<define-fold>
(define-syntax define-fold
(syntax-parser
[(_ _function-name:id
_type-name:id
whole-type:type
_type-to-replaceᵢ:type …)
(with-folds
(λ ()
#`(begin
(define-type _type-name
#,(fold-type #'(whole-type _type-to-replaceᵢ …)))
(define _function-name
#,(fold-f #'(whole-type _type-to-replaceᵢ …))))))]))]
where @racket[foldl-map] is defined as: where @racket[foldl-map] is defined as:
@chunk[<foldl-map> @chunk[<foldl-map>
@ -378,7 +373,6 @@ where @racket[foldl-map] is defined as:
(subtract-in (combine-in racket/base (subtract-in (combine-in racket/base
syntax/parse) syntax/parse)
"subtemplate-override.rkt") "subtemplate-override.rkt")
;syntax/parse/experimental/template
backport-template-pr1514/experimental/template backport-template-pr1514/experimental/template
phc-toolkit/untyped phc-toolkit/untyped
racket/syntax racket/syntax
@ -389,10 +383,15 @@ where @racket[foldl-map] is defined as:
(for-meta 2 phc-toolkit/untyped) (for-meta 2 phc-toolkit/untyped)
(for-meta 2 syntax/parse)) (for-meta 2 syntax/parse))
(provide with-folds (provide (for-syntax with-folds
(for-syntax replace-in-instance) replace-in-type
(for-syntax replace-in-type)) ∀-replace-in-type
replace-in-instance
λ-replace-in-instance))
<foldl-map> <foldl-map>
<with-folds> <with-folds>
<cached> <cached>
<define-fold>] (begin-for-syntax
<api>
<fold-τ>
<fold-f>)]