forked from bldl/magnolisp
-
Notifications
You must be signed in to change notification settings - Fork 0
/
ast-serialize.rkt
101 lines (91 loc) · 3.1 KB
/
ast-serialize.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
#lang racket/base
#|
A generic method 'syntactifiable-mkstx' for AST marshaling as syntax.
It is assumed that each AST node type implements the generic interface
'gen:syntactifiable', and hence also 'syntactifiable-mkstx'. Common
Racket datatypes are also supported by the generic method. This
includes syntax objects, but in a somewhat lossy way. Mutability and
weakness properties of collection types may also not be preserved.
|#
(require racket/generic
"util.rkt"
(for-template racket/base))
(define (quotable? x)
(any-pred-holds
symbol? number? boolean? string? char? keyword? bytes? regexp?
x))
(define (hash-maker-id-for x)
(cond
[(hash-eq? x) #'make-immutable-hasheq]
[(hash-eqv? x) #'make-immutable-hasheqv]
[(hash-equal? x) #'make-immutable-hash]
[else
(error
'hash-maker-id-for
"expected (or/c hash-eq? hash-eqv? hash-equal?): ~s" x)]))
(define-generics* syntactifiable
(syntactifiable-mkstx syntactifiable)
#:defaults
(
[syntax?
(define (syntactifiable-mkstx x)
#`(quote-syntax #,x #:local))]
[null?
(define (syntactifiable-mkstx x)
#'null)]
[pair?
(define/generic f syntactifiable-mkstx)
(define (syntactifiable-mkstx x)
(if (list? x)
#`(list #,@(map f x))
#`(cons #,(f (car x)) #,(f (cdr x)))))]
[box?
(define/generic f syntactifiable-mkstx)
(define (syntactifiable-mkstx x)
#`(box-immutable #,(f (unbox x))))]
[vector?
(define/generic f syntactifiable-mkstx)
(define (syntactifiable-mkstx x)
#`(vector-immutable
#,@(for/list ([v (in-vector x)])
(f v))))]
[prefab-struct-key
(define/generic f syntactifiable-mkstx)
(define (syntactifiable-mkstx x)
(define lst (cdr (vector->list (struct->vector x))))
(define key (prefab-struct-key x))
#`(make-prefab-struct '#,key #,@(map f lst)))]
[hash?
(define/generic f syntactifiable-mkstx)
(define (syntactifiable-mkstx x)
(define make (hash-maker-id-for x))
#`(#,make (list #,@(for/list ([(k v) x])
#`(cons #,(f k) #,(f v))))))]
[path?
(define (syntactifiable-mkstx x)
#`(bytes->path #,(path->bytes x)))]
[quotable?
(define (syntactifiable-mkstx x)
#`(quote #,x))]
))
(module* test #f
(require racket rackunit)
(for ([dat (list #f 1 'x "x" #'x '() '(1 2 3)
#&7 #(1 2 3)
#s(Obj 1) #s(Obj car)
#hasheq() #'#hasheq()
#hasheq((foo . 1))
#hasheq((foo . car))
#hasheqv((1 . 2))
#hasheqv((1 . 2) (3 . car))
#hash(("foo" . car) ("bar" . cdr))
'(#'(1 2 3))
(list 'no-check #'x)
(list 'no-check "obj" (hasheq 'stx #'(m) 'origin (list #'x #'y)))
)])
(define stx (syntactifiable-mkstx dat))
;;(writeln (syntax->datum stx))
(define val (eval-syntax stx))
(unless (or (syntax? dat) (and (pair? dat) (eq? (car dat) 'no-check)))
(check-equal? dat val)))
(void))