blob: 53d3beee16095233e990e77364b34adeaa873279 (
about) (
plain)
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
;;; print-types.scm -- print type-related AST structures
;;;
;;; author : Sandra Loosemore
;;; date : 15 Jan 1991
;;;
;;; This file corresponds to the stuff in ast/type-structs.scm
;;;
(define-ast-printer tyvar (object xp)
(write-avarid (tyvar-name object) xp))
;;; Various type special cases have a magic cookie in the def field.
(define-ast-printer tycon (object xp)
(print-general-tycon (tycon-def object) (tycon-args object) object xp))
(define (print-general-tycon def args object xp)
(cond ((eq? def (core-symbol "Arrow"))
(write-arrow-tycon args xp))
((eq? def (core-symbol "UnitType"))
(write-unit-tycon xp))
((eq? def (core-symbol "List"))
(write-list-tycon args xp))
((is-tuple-tycon? def)
(write-tuple-tycon args xp))
(else
(write-ordinary-tycon def args object xp))))
(define (write-arrow-tycon args xp)
(with-ast-block (xp)
(write-btype (car args) xp)
(write-string " ->" xp)
(write-whitespace xp)
(write (cadr args) xp)))
(define (write-unit-tycon xp)
(write-string "()" xp))
(define (write-list-tycon args xp)
(with-ast-block (xp)
(write-char #\[ xp)
(write (car args) xp)
(write-char #\] xp)))
(define (write-tuple-tycon args xp)
(write-commaized-list args xp))
(define (write-ordinary-tycon def args object xp)
(with-ast-block (xp)
(if (tycon? object)
(write-tyconid (tycon-name object) xp)
(write-tyconid (def-name def) xp))
(when (not (null? args))
(write-whitespace xp)
(write-delimited-list
args xp (function write-atype) "" "" ""))))
;;; All of the special cases above except "Arrow" are atypes, as is
;;; a tyvar or a tycon with no arguments.
(define (write-atype object xp)
(let ((object (maybe-prune object)))
(if (or (tyvar? object)
(gtyvar? object)
(ntyvar? object)
(is-some-tycon? object
(lambda (def)
(or (eq? def (core-symbol "UnitType"))
(eq? def (core-symbol "List"))
(is-tuple-tycon? def)))))
(write object xp)
(begin
(write-char #\( xp)
(write object xp)
(write-char #\) xp)))))
;;; A btype is any type except the arrow tycon.
(define (write-btype object xp)
(let ((object (maybe-prune object)))
(if (or (and (tycon? object)
(eq? (tycon-def object) (core-symbol "Arrow")))
(and (ntycon? object)
(eq? (ntycon-tycon object) (core-symbol "Arrow"))))
(begin
(write-char #\( xp)
(write object xp)
(write-char #\) xp))
(write object xp))))
(define (maybe-prune object)
(if (ntyvar? object)
(prune object)
object))
(define (is-some-tycon? object fn)
(let ((object (maybe-prune object)))
(or (and (tycon? object)
(or (null? (tycon-args object))
(funcall fn (tycon-def object))))
(and (ntycon? object)
(or (null? (ntycon-args object))
(funcall fn (ntycon-tycon object)))))))
(define-ast-printer context (object xp)
(with-ast-block (xp)
(write (context-class object) xp)
(write-whitespace xp)
(write-avarid (context-tyvar object) xp)))
(define-ast-printer signature (object xp)
(write-contexts (signature-context object) xp)
(write (signature-type object) xp))
(define (write-contexts contexts xp)
(when (not (null? contexts))
(if (null? (cdr contexts))
(write (car contexts) xp)
(write-commaized-list contexts xp))
(write-string " =>" xp)
(write-whitespace xp)))
(define-ast-printer synonym-decl (object xp)
(with-ast-block (xp)
(write-string "type " xp)
(write (synonym-decl-simple object) xp)
(write-string " =" xp)
(write-whitespace xp)
(write (synonym-decl-body object) xp)))
(define-ast-printer data-decl (object xp)
(with-ast-block (xp)
(write-string "data " xp)
(write-contexts (data-decl-context object) xp)
(write (data-decl-simple object) xp)
(write-whitespace xp)
(write-char #\= xp)
(write-whitespace xp)
(write-delimited-list
(data-decl-constrs object) xp (function write) " |" "" "")
(write-whitespace xp)
(let ((deriving (data-decl-deriving object)))
(when (not (null? deriving))
(write-string "deriving " xp)
(if (null? (cdr deriving))
(write (car deriving) xp)
(write-commaized-list deriving xp))))))
(define-ast-printer constr (object xp)
(if (con-ref-infix? (constr-constructor object))
(with-ast-block (xp)
(write-btype (car (constr-types object)) xp)
(write-whitespace xp)
(write (constr-constructor object) xp)
(write-whitespace xp)
(write-btype (cadr (constr-types object)) xp))
(with-ast-block (xp)
(write (constr-constructor object) xp)
(when (not (null? (constr-types object)))
(write-whitespace xp)
(write-delimited-list
(constr-types object) xp (function write-atype) "" "" "")))))
(define-ast-printer class-decl (object xp)
(with-ast-block (xp)
(write-string "class " xp)
(write-contexts (class-decl-super-classes object) xp)
(write (class-decl-class object) xp)
(write-whitespace xp)
(write-avarid (class-decl-class-var object) xp)
(write-wheredecls (class-decl-decls object) xp)))
(define-ast-printer instance-decl (object xp)
(with-ast-block (xp)
(write-string "instance " xp)
(write-contexts (instance-decl-context object) xp)
(write (instance-decl-class object) xp)
(write-whitespace xp)
(write-atype (instance-decl-simple object) xp)
(write-wheredecls (instance-decl-decls object) xp)))
;;; Don't print out default decl if the value is the default.
(define-ast-printer default-decl (object xp)
(with-ast-block (xp)
(write-string "default " xp)
(let ((types (default-decl-types object)))
(if (null? (cdr types))
(write (car types) xp)
(write-commaized-list types xp)))))
(define-ast-printer class-ref (object xp)
(write-tyclsid (class-ref-name object) xp))
|
