/
repr.rkt
141 lines (132 loc) · 3.97 KB
/
repr.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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
#lang racket/base
(provide
number->type
numeric-type-natural
numeric-type-integer
numeric-type-exact
numeric-type-inexact
numeric-type-complex-exact
numeric-type-complex-inexact
(struct-out repr)
repr->value
repr-entry-pair
repr-entry-vector
repr-entry-struct
repr-entry-hash
repr-type->constructor
struct->type
struct->components
value->repr
)
(require
"comparison.rkt"
"record.rkt"
"sugar.rkt"
racket/function
racket/match
racket/set
)
(module+ test
(require rackunit))
(record repr type components)
(define numeric-type-natural '(number real exact integer natural))
(define numeric-type-integer '(number real exact integer))
(define numeric-type-exact '(number real exact))
(define numeric-type-inexact '(number real inexact))
(define numeric-type-complex-exact '(number complex exact))
(define numeric-type-complex-inexact '(number complex inexact))
(define (number->type num)
(if (real? num)
(if (exact? num)
(if (integer? num)
(if (<= 0 num) numeric-type-natural numeric-type-integer)
numeric-type-exact)
numeric-type-inexact)
(if (exact? num) numeric-type-complex-exact numeric-type-complex-inexact)))
(def (struct->type val)
(values sty _) = (struct-info val)
sty)
(define (struct->components val) (cdr (vector->list (struct->vector val))))
(define repr-entry-pair
(list pair? (const 'pair) (fn ((cons a d)) (list a d))))
(define repr-entry-vector (list vector? (const 'vector) vector->list))
(define repr-entry-struct (list struct? struct->type struct->components))
(define repr-entry-hash (list hash? (const 'hash) hash->list-sorted))
(define repr-entries
`((,void? ,(const 'void) ,identity)
(,boolean? ,(const 'boolean) ,identity)
(,symbol? ,(const 'symbol) ,identity)
(,char? ,(const 'char) ,identity)
(,string? ,(const 'string) ,identity)
(,number? ,number->type ,identity)
(,null? ,(const 'nil) ,identity)
,repr-entry-pair
,repr-entry-vector
,repr-entry-struct
,repr-entry-hash
(,set? ,(const 'set) ,set->list-sorted)
(,procedure? ,(const 'procedure) ,identity)
(,(const #t) ,(const 'unknown) ,identity)))
(define (value->repr val)
(forf result = (void)
(list found? val->type val->components) <- repr-entries
#:break (not (void? result))
(when (found? val) (repr (val->type val) (val->components val)))))
(define (repr-type->constructor type)
(match type
('void identity)
('boolean identity)
('symbol identity)
('char identity)
('string identity)
(`(number . ,_) identity)
('nil identity)
('pair (curry apply cons))
('vector list->vector)
('hash make-immutable-hash)
('set list->set)
((? struct-type?) (curry apply (struct-type-make-constructor type)))
('procedure identity)
('unknown identity)))
(def (repr->value (repr type components))
((repr-type->constructor type) components))
(module+ test
(lets
vals = (list
(void)
#f
'name
#\c
"string"
4
'()
(cons (cons 5 'a) (cons 6 '()))
#(7 8 9)
(hash 'one 1 'two 2)
(set 'one 'three 'four)
(repr 'repr-type 'repr-component)
identity
(box 'box)
)
(list vvoid vbool vsym vchar vstring vnum vnil
vpair vvec vhash vset vstruct vproc vunk) = vals
expected-reprs = (map (curry apply repr)
`((void ,(void))
(boolean #f)
(symbol name)
(char #\c)
(string "string")
(,numeric-type-natural 4)
(nil ())
(pair ((5 . a) (6)))
(vector (7 8 9))
(hash ,(hash->list-sorted vhash))
(set ,(set->list-sorted vset))
(,(struct->type vstruct) (repr-type repr-component))
(procedure ,vproc)
(unknown ,vunk)))
reprs = (map value->repr vals)
(begin
(check-equal? (map repr->value reprs) vals)
(check-equal? reprs expected-reprs)
)))