syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fix the serializer

This commit is contained in:
Michael Ballantyne 2020-09-24 22:07:49 -06:00 committed by Sam Caldwell
parent 122ef0b5f9
commit 50d2d1a6fa
1 changed files with 43 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
racket/typed/syntax-serializer.rkt
View File

@ -10,6 +10,8 @@
(struct datum-val (d) #:prefab) (struct datum-val (d) #:prefab)
(struct ref (unique-tag sym) #:prefab) (struct ref (unique-tag sym) #:prefab)
;(require racket/pretty)
(define (serialize-syntax stx) (define (serialize-syntax stx)
(define unique-tag (gensym)) (define unique-tag (gensym))
(define table (hasheq)) (define table (hasheq))
@ -28,24 +30,29 @@
(define serialized-val (define serialized-val
(if (syntax? val) (if (syntax? val)
(syntax-val (serialize-element! val)) (syntax-val (serialize-element! val))
(datum-val (serialize-element! val)))) (datum-val (serialize-element! val #:always-lift? #t))))
(cons k serialized-val)))) (cons k serialized-val))))
(define (serialize-element! el) (define (serialize-element! el #:always-lift? [always-lift? #f])
(syntax-map (syntax-map
el el
(lambda (tail? d) d) (lambda (tail? d) d)
(lambda (orig-s d) (lambda (orig-s d)
(if (not (ormap (lambda (p) (syntax-property-preserved? orig-s p)) (if (or always-lift?
(syntax-property-symbol-keys orig-s))) (ormap (lambda (p) (syntax-property-preserved? orig-s p))
(datum->syntax orig-s d orig-s #f) (syntax-property-symbol-keys orig-s)))
(lift! (build-props! orig-s d)))) (lift! (build-props! orig-s d))
(datum->syntax orig-s d orig-s #f)))
syntax-e)) syntax-e))
(define top-s (serialize-element! stx)) (define top-s (serialize-element! stx))
(datum->syntax #f (serialized-syntax unique-tag table top-s))) (datum->syntax #f (serialized-syntax unique-tag table top-s)))
(define (deserialize-syntax ser) (define (deserialize-syntax ser)
;(displayln 'deserialize-in)
;(print-syntax-width +inf.0)
;(println ser)
;(pretty-print (syntax->datum ser))
(match (syntax-e ser) (match (syntax-e ser)
[(serialized-syntax unique-tag-stx table-stx contents) [(serialized-syntax unique-tag-stx table-stx contents)
(define unique-tag (syntax-e unique-tag-stx)) (define unique-tag (syntax-e unique-tag-stx))
@ -56,7 +63,8 @@
(define (deserialize-stx-with-props ref-sym) (define (deserialize-stx-with-props ref-sym)
(match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym))) (match-define (stx-with-props stx ps) (syntax-e (hash-ref table ref-sym)))
(for/fold ([stx stx]) (define deserialized-nested-stx (deserialize-element stx))
(for/fold ([stx deserialized-nested-stx])
([stx-pr (syntax->list ps)]) ([stx-pr (syntax->list ps)])
(define pr (syntax-e stx-pr)) (define pr (syntax-e stx-pr))
(define k (syntax-e (car pr))) (define k (syntax-e (car pr)))
@ -81,15 +89,29 @@
(lambda (orig-s d) (datum->syntax orig-s d orig-s #f)) (lambda (orig-s d) (datum->syntax orig-s d orig-s #f))
syntax-e)) syntax-e))
(deserialize-element contents)])) (define res (deserialize-element contents))
;(displayln 'deserialize-out)
;(println res)
;(pretty-print (syntax->datum res))
res]))
(module+ test (module+ test
(require rackunit) (require rackunit)
(define orig #`(1 #,(syntax-property #'2 ': (syntax-property #'Int ':: #'Type #t) #t))) (define type
(define s (serialize-syntax orig)) (syntax-property
(syntax-property #'Int ':: #'Type #t)
'orig (list #'Int) #t))
(define term (syntax-property #`(1 #,(syntax-property #'2 ': type #t)) ': #'Type #t))
(define s (serialize-syntax term))
(define d (deserialize-syntax s)) (define d (deserialize-syntax s))
(check-true
(bound-identifier=?
(syntax-property d ':)
#'Type))
; syntax with properties inside outer syntax with properties.
(check-true (check-true
(bound-identifier=? (bound-identifier=?
(syntax-property (syntax-property (cadr (syntax-e d)) ':) '::) (syntax-property (syntax-property (cadr (syntax-e d)) ':) '::)
@ -101,16 +123,23 @@
#'Int)) #'Int))
(check-equal? (check-equal?
(syntax-position orig) (syntax-position term)
(syntax-position d)) (syntax-position d))
(check-equal? (check-equal?
(syntax-position (syntax-property (cadr (syntax-e orig)) ':)) (syntax-position (syntax-property (cadr (syntax-e term)) ':))
(syntax-position (syntax-property (cadr (syntax-e d)) ':))) (syntax-position (syntax-property (cadr (syntax-e d)) ':)))
(check-equal? (check-equal?
(syntax-position (car (syntax-e orig))) (syntax-position (car (syntax-e term)))
(syntax-position (car (syntax-e d))))) (syntax-position (car (syntax-e d))))
; syntax in datum in properties
(check-true
(bound-identifier=?
(car (syntax-property (syntax-property (cadr (syntax-e d)) ':) 'orig))
#'Int))
)
;; ---------------------------------------------------------------- ;; ----------------------------------------------------------------