try out the syntax serializer
This commit is contained in:
Sam Caldwell
parent
e1ca7ba2c4
commit
122ef0b5f9
|
|
@ -35,6 +35,7 @@
|
|||
(require (postfix-in - racket/set))
|
||||
(require (postfix-in - racket/match))
|
||||
(require (postfix-in - (only-in racket/format ~a)))
|
||||
(require (for-syntax "syntax-serializer.rkt"))
|
||||
|
||||
|
||||
(module+ test
|
||||
|
|
@ -431,9 +432,10 @@
|
|||
(define-syntax define-type-alias
|
||||
(syntax-parser
|
||||
[(_ alias:id τ:type)
|
||||
#:with kind (detach #'τ.norm ':)
|
||||
;; #:with kind (detach #'τ.norm ':)
|
||||
#:with serialized-τ (serialize-syntax #'τ.norm)
|
||||
#'(define-syntax- alias
|
||||
(make-variable-like-transformer (attach #'τ ': #'kind)))]
|
||||
(make-variable-like-transformer (deserialize-syntax #'serialized-τ)))]
|
||||
[(_ (f:id x:id ...) ty)
|
||||
#'(define-syntax- (f stx)
|
||||
(syntax-parse stx
|
||||
|
|
@ -773,24 +775,14 @@
|
|||
#:datum-literals (:)
|
||||
[(_ lib [name:id : ty:type] ...)
|
||||
#:with (name- ...) (format-ids "~a-" #'(name ...))
|
||||
#:with (kind ...) (for/list ([t (in-syntax #'(ty.norm ...))])
|
||||
(detach t ':))
|
||||
(define nm1 (syntax-e (first (syntax->list #'(name ...)))))
|
||||
(define kind1 (first (syntax->list #'(kind ...))))
|
||||
(when (equal? nm1 'identity)
|
||||
(printf "require/typed: ~a\n" nm1)
|
||||
(syntax-parse kind1
|
||||
[(~Base t)
|
||||
(define t-i (syntax-local-introduce #'t))
|
||||
(pretty-print (syntax-debug-info t-i))
|
||||
(pretty-print (identifier-binding t-i))]))
|
||||
#:with (serialized-ty ...) (for/list ([t (in-syntax #'(ty.norm ...))])
|
||||
(serialize-syntax t))
|
||||
(syntax/loc stx
|
||||
(begin-
|
||||
(require (only-in lib [name name-] ...))
|
||||
(define-syntax name
|
||||
(make-variable-like-transformer
|
||||
(add-orig (assign-type #'name-
|
||||
(attach #'ty ': ((current-type-eval) #'Type))
|
||||
(add-orig (assign-type #'name- (deserialize-syntax #'serialized-ty)
|
||||
#:wrap? #f) #'name)))
|
||||
...))]))
|
||||
|
||||
|
|
@ -1406,12 +1398,12 @@
|
|||
(define-for-syntax (int-def-ctx-bind-type-rename x x- t ctx)
|
||||
(when DEBUG-BINDINGS?
|
||||
(printf "adding to context ~a\n" (syntax-debug-info x)))
|
||||
(define kind (detach t KIND-TAG))
|
||||
(define serialized-ty (serialize-syntax t))
|
||||
(syntax-local-bind-syntaxes (list x-) #f ctx)
|
||||
(syntax-local-bind-syntaxes (list x)
|
||||
#`(make-rename-transformer
|
||||
(add-orig
|
||||
(attach #'#,x- ': (attach #'#,t '#,KIND-TAG #'#,kind))
|
||||
(attach #'#,x- ': (deserialize-syntax #'#,serialized-ty))
|
||||
#'#,x)
|
||||
#;(add-orig (assign-type #'#,x- #'#,t #:wrap? #f) #'#,x))
|
||||
ctx))
|
||||
|
|
@ -1499,10 +1491,10 @@
|
|||
[(_ x:id x-:id τ e)
|
||||
;; including a syntax binding for x allows for module-top-level references
|
||||
;; (where walk/bind won't replace further uses) and subsequent provides
|
||||
#:with kind (detach #'τ ':)
|
||||
#:with serialized-τ (serialize-syntax #'τ)
|
||||
#'(begin-
|
||||
(define-syntax x
|
||||
(make-variable-like-transformer (add-orig (attach #'x- ': (attach #'τ ': #'kind)) #'x)))
|
||||
(make-variable-like-transformer (add-orig (attach #'x- ': (deserialize-syntax #'serialized-τ)) #'x)))
|
||||
(define- x- e))]))
|
||||
|
||||
;; copied from ext-stlc
|
||||
|
|
@ -1628,6 +1620,7 @@
|
|||
[⊢ e_fn ≫ e_fn- ⇒ (~∀+ Xs (~→fn tyX_in ... tyX_out))]
|
||||
;; successfully matched a polymorphic fn type, don't backtrack
|
||||
#:cut
|
||||
#:do [(printf "A\n")]
|
||||
#:with tyX_args #'(tyX_in ... tyX_out)
|
||||
;; solve for type variables Xs
|
||||
#:with [[e_arg- ...] Xs* cs] (solve #'Xs #'tyX_args this-syntax)
|
||||
|
|
@ -1638,6 +1631,7 @@
|
|||
(instantiable? x ty))
|
||||
"type variables must be flat and finite"
|
||||
;; instantiate polymorphic function type
|
||||
#:do [(printf "B\n")]
|
||||
#:with [τ_in ... τ_out] (ttc:inst-types/cs #'Xs* #'cs #'tyX_args)
|
||||
#:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out)
|
||||
;; arity check
|
||||
|
|
@ -1649,6 +1643,7 @@
|
|||
#:with (τ_arg ...) (stx-map typeof #'(e_arg- ...))
|
||||
;; typecheck args
|
||||
[τ_arg τ⊑ τ_in #:for e_arg] ...
|
||||
#:do [(printf "C\n")]
|
||||
#:with τ_out* (if (stx-null? #'(unsolved-X ...))
|
||||
#'τ_out
|
||||
(syntax-parse #'τ_out
|
||||
|
|
@ -1661,7 +1656,8 @@
|
|||
#f
|
||||
(mk-app-poly-infer-error this-syntax #'(τ_in ...) #'(τ_arg ...) #'e_fn)
|
||||
this-syntax)))
|
||||
((type-eval) #'(∀+ (unsolved-X ... Y ...) τ_out))]))
|
||||
(type-eval #'(∀+ (unsolved-X ... Y ...) τ_out))]))
|
||||
#:do [(printf "D\n")]
|
||||
--------
|
||||
[⊢ (#%plain-app- e_fn- e_arg- ...) ⇒ τ_out*]]
|
||||
;; All Other Functions
|
||||
|
|
|
|||
|
|
@ -0,0 +1,247 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide serialize-syntax deserialize-syntax)
|
||||
|
||||
(require racket/dict racket/match)
|
||||
|
||||
(struct serialized-syntax (unique-tag table contents) #:prefab)
|
||||
(struct stx-with-props (stx ps) #:prefab)
|
||||
(struct syntax-val (stx) #:prefab)
|
||||
(struct datum-val (d) #:prefab)
|
||||
(struct ref (unique-tag sym) #:prefab)
|
||||
|
||||
(define (serialize-syntax stx)
|
||||
(define unique-tag (gensym))
|
||||
(define table (hasheq))
|
||||
|
||||
(define (lift! el)
|
||||
(define tag-sym (gensym))
|
||||
(set! table (hash-set table tag-sym el))
|
||||
(ref unique-tag tag-sym))
|
||||
|
||||
(define (build-props! orig-s d)
|
||||
(stx-with-props
|
||||
(datum->syntax orig-s d orig-s #f)
|
||||
(for/list ([k (syntax-property-symbol-keys orig-s)]
|
||||
#:when (syntax-property-preserved? orig-s k))
|
||||
(define val (syntax-property orig-s k))
|
||||
(define serialized-val
|
||||
(if (syntax? val)
|
||||
(syntax-val (serialize-element! val))
|
||||
(datum-val (serialize-element! val))))
|
||||
(cons k serialized-val))))
|
||||
|
||||
(define (serialize-element! el)
|
||||
(syntax-map
|
||||
el
|
||||
(lambda (tail? d) d)
|
||||
(lambda (orig-s d)
|
||||
(if (not (ormap (lambda (p) (syntax-property-preserved? orig-s p))
|
||||
(syntax-property-symbol-keys orig-s)))
|
||||
(datum->syntax orig-s d orig-s #f)
|
||||
(lift! (build-props! orig-s d))))
|
||||
syntax-e))
|
||||
|
||||
(define top-s (serialize-element! stx))
|
||||
(datum->syntax #f (serialized-syntax unique-tag table top-s)))
|
||||
|
||||
(define (deserialize-syntax ser)
|
||||
(match (syntax-e ser)
|
||||
[(serialized-syntax unique-tag-stx table-stx contents)
|
||||
(define unique-tag (syntax-e unique-tag-stx))
|
||||
(define table (syntax-e table-stx))
|
||||
|
||||
(define (maybe-syntax-e v)
|
||||
(if (syntax? v) (syntax-e v) v))
|
||||
|
||||
(define (deserialize-stx-with-props ref-sym)
|
||||
(match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym)))
|
||||
(for/fold ([stx stx])
|
||||
([stx-pr (syntax->list ps)])
|
||||
(define pr (syntax-e stx-pr))
|
||||
(define k (syntax-e (car pr)))
|
||||
(define v (syntax-e (cdr pr)))
|
||||
(define prop-val
|
||||
(match v
|
||||
[(syntax-val v)
|
||||
(deserialize-element v)]
|
||||
[(datum-val v)
|
||||
(deserialize-element (syntax->datum v))]))
|
||||
(syntax-property stx k prop-val #t)))
|
||||
|
||||
(define (deserialize-element el)
|
||||
(syntax-map
|
||||
el
|
||||
(lambda (tail? d)
|
||||
(match d
|
||||
[(ref tag sym)
|
||||
#:when (equal? (maybe-syntax-e tag) unique-tag)
|
||||
(deserialize-stx-with-props (maybe-syntax-e sym))]
|
||||
[_ d]))
|
||||
(lambda (orig-s d) (datum->syntax orig-s d orig-s #f))
|
||||
syntax-e))
|
||||
|
||||
(deserialize-element contents)]))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define orig #`(1 #,(syntax-property #'2 ': (syntax-property #'Int ':: #'Type #t) #t)))
|
||||
(define s (serialize-syntax orig))
|
||||
(define d (deserialize-syntax s))
|
||||
|
||||
(check-true
|
||||
(bound-identifier=?
|
||||
(syntax-property (syntax-property (cadr (syntax-e d)) ':) '::)
|
||||
#'Type))
|
||||
|
||||
(check-true
|
||||
(bound-identifier=?
|
||||
(syntax-property (cadr (syntax-e d)) ':)
|
||||
#'Int))
|
||||
|
||||
(check-equal?
|
||||
(syntax-position orig)
|
||||
(syntax-position d))
|
||||
|
||||
(check-equal?
|
||||
(syntax-position (syntax-property (cadr (syntax-e orig)) ':))
|
||||
(syntax-position (syntax-property (cadr (syntax-e d)) ':)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-position (car (syntax-e orig)))
|
||||
(syntax-position (car (syntax-e d)))))
|
||||
|
||||
|
||||
;; ----------------------------------------------------------------
|
||||
|
||||
;; syntax-map and datum-map copied from the expander files
|
||||
;; syntax/datum-map.rkt
|
||||
;; syntax/syntax.rkt
|
||||
|
||||
(require racket/fixnum racket/prefab)
|
||||
|
||||
;; `(datum-map v f)` walks over `v`, traversing objects that
|
||||
;; `datum->syntax` traverses to convert content to syntax objects.
|
||||
;;
|
||||
;; `(f tail? d)` is called on each datum `d`, where `tail?`
|
||||
;; indicates that the value is a pair/null in a `cdr` --- so that it
|
||||
;; doesn't need to be wrapped for `datum->syntax`, for example;
|
||||
;; the `tail?` argument is actually #f or a fixnum for a lower bound
|
||||
;; on `cdr`s that have been taken
|
||||
;;
|
||||
;; `gf` is like `f`, but `gf` is used when the argument might be
|
||||
;; syntax; if `gf` is provided, `f` can assume that its argument
|
||||
;; is not syntax
|
||||
;;
|
||||
;; If a `seen` argument is provided, then it should be an `eq?`-based
|
||||
;; hash table, and cycle checking is enabled; when a cycle is
|
||||
;; discovered, the procedure attached to 'cycle-fail in the initial
|
||||
;; table is called
|
||||
;;
|
||||
;; If a `known-pairs` argument is provided, then it should be an
|
||||
;; `eq?`-based hash table to map pairs that can be returned as-is
|
||||
;; in a `tail?` position
|
||||
|
||||
;; The inline version uses `f` only in an application position to
|
||||
;; help avoid allocating a closure. It also covers only the most common
|
||||
;; cases, defering to the general (not inlined) function for other cases.
|
||||
(define (datum-map s f [gf f] [seen #f] [known-pairs #f])
|
||||
(let loop ([tail? #f] [s s] [prev-depth 0])
|
||||
(define depth (fx+ 1 prev-depth)) ; avoid cycle-checking overhead for shallow cases
|
||||
(cond
|
||||
[(and seen (depth . fx> . 32))
|
||||
(datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)]
|
||||
[(null? s) (f tail? s)]
|
||||
[(pair? s)
|
||||
(f tail? (cons (loop #f (car s) depth)
|
||||
(loop 1 (cdr s) depth)))]
|
||||
[(symbol? s) (f #f s)]
|
||||
[(boolean? s) (f #f s)]
|
||||
[(number? s) (f #f s)]
|
||||
[(or (vector? s) (box? s) (prefab-struct-key s) (hash? s))
|
||||
(datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen known-pairs)]
|
||||
[else (gf #f s)])))
|
||||
|
||||
(define (datum-map-slow tail? s f seen known-pairs)
|
||||
(let loop ([tail? tail?] [s s] [prev-seen seen])
|
||||
(define seen
|
||||
(cond
|
||||
[(and prev-seen (datum-has-elements? s))
|
||||
(cond
|
||||
[(hash-ref prev-seen s #f)
|
||||
((hash-ref prev-seen 'cycle-fail) s)]
|
||||
[else (hash-set prev-seen s #t)])]
|
||||
[else prev-seen]))
|
||||
(cond
|
||||
[(null? s) (f tail? s)]
|
||||
[(pair? s)
|
||||
(cond
|
||||
[(and known-pairs
|
||||
tail?
|
||||
(hash-ref known-pairs s #f))
|
||||
s]
|
||||
[else
|
||||
(f tail? (cons (loop #f (car s) seen)
|
||||
(loop (if tail? (fx+ 1 tail?) 1) (cdr s) seen)))])]
|
||||
[(or (symbol? s) (boolean? s) (number? s))
|
||||
(f #f s)]
|
||||
[(vector? s)
|
||||
(f #f (vector->immutable-vector
|
||||
(for/vector #:length (vector-length s) ([e (in-vector s)])
|
||||
(loop #f e seen))))]
|
||||
[(box? s)
|
||||
(f #f (box-immutable (loop #f (unbox s) seen)))]
|
||||
[(immutable-prefab-struct-key s)
|
||||
=> (lambda (key)
|
||||
(f #f
|
||||
(apply make-prefab-struct
|
||||
key
|
||||
(for/list ([e (in-vector (struct->vector s) 1)])
|
||||
(loop #f e seen)))))]
|
||||
[(and (hash? s) (immutable? s))
|
||||
(cond
|
||||
[(hash-eq? s)
|
||||
(f #f
|
||||
(for/hasheq ([(k v) (in-hash s)])
|
||||
(values k (loop #f v seen))))]
|
||||
[(hash-eqv? s)
|
||||
(f #f
|
||||
(for/hasheqv ([(k v) (in-hash s)])
|
||||
(values k (loop #f v seen))))]
|
||||
[else
|
||||
(f #f
|
||||
(for/hash ([(k v) (in-hash s)])
|
||||
(values k (loop #f v seen))))])]
|
||||
[else (f #f s)])))
|
||||
|
||||
(define (datum-has-elements? d)
|
||||
(or (pair? d)
|
||||
(vector? d)
|
||||
(box? d)
|
||||
(immutable-prefab-struct-key d)
|
||||
(and (hash? d) (immutable? d) (positive? (hash-count d)))))
|
||||
|
||||
;; `(syntax-map s f d->s)` walks over `s`:
|
||||
;;
|
||||
;; * `(f tail? d)` is called to each datum `d`, where `tail?`
|
||||
;; indicates that the value is a pair/null in a `cdr` --- so that it
|
||||
;; doesn't need to be wrapped for `datum->syntax`, for example
|
||||
;;
|
||||
;; * `(d->s orig-s d)` is called for each syntax object,
|
||||
;; and the second argument is result of traversing its datum
|
||||
;;
|
||||
;; * the `s-e` function extracts content of a syntax object
|
||||
;;
|
||||
;; The optional `seen` argument is an `eq?`-based immutable hash table
|
||||
;; to detect and reject cycles. See `datum-map`.
|
||||
|
||||
(define (syntax-map s f d->s s-e [seen #f])
|
||||
(let loop ([s s])
|
||||
(datum-map s
|
||||
f
|
||||
(lambda (tail? v)
|
||||
(cond
|
||||
[(syntax? v) (d->s v (loop (s-e v)))]
|
||||
[else (f tail? v)]))
|
||||
seen)))
|
||||
Loading…
Reference in New Issue