blob: b128486d433992d4c3ae4c5b17fbf77abbbaf070 (
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
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
;;; Description: Convert algdata & synonym from ast to definition form.
;;; Lots of error checking.
;;; Algdata:
;;; Errors detected:
;;; Types & classes (deriving & context) resolved
;;; context tyvars must be parameters
;;; all parameter tyvars must be referenced
;;; only parameter tyvars must be referenced
(define (algdata->def data-decl)
(remember-context data-decl
(with-slots data-decl (context simple constrs deriving annotations) data-decl
(let* ((def (tycon-def simple))
(tyvars (simple-tyvar-list simple))
(enum? '#t)
(tag 0)
(derived-classes '())
(tyvars-referenced '())
(all-con-vars '())
(all-strict? (process-alg-strictness-annotation annotations))
(constr-defs
(map (lambda (constr)
(with-slots constr (constructor types) constr
(let ((constr-def (con-ref-con constructor))
(c-arity (length types))
(con-vars '())
(all-types '())
(strictness '()))
(when (not (eqv? c-arity 0))
(setf enum? '#f))
(dolist (type types)
(let* ((ty (tuple-2-1 type))
(anns (tuple-2-2 type))
(tyvars1 (resolve-type ty)))
(push ty all-types)
(push (get-constr-strictness anns all-strict?)
strictness)
(dolist (v tyvars1)
(if (not (memq v tyvars))
(signal-bad-algdata-tyvar v)))
(setf con-vars (append tyvars1 tyvars-referenced))
(setf tyvars-referenced
(append tyvars1 tyvars-referenced))))
(push (tuple constr con-vars) all-con-vars)
(update-slots con constr-def
(arity c-arity)
(types (reverse all-types))
(tag tag)
(alg def)
(infix? (con-ref-infix? constructor))
(slot-strict? (reverse strictness)))
(incf tag)
constr-def)))
constrs)))
(dolist (class deriving)
(if (eq? (class-ref-name class) '|Printers|)
(setf (class-ref-class class) *printer-class*)
(resolve-class class))
(when (not (eq? (class-ref-class class) *undefined-def*))
(push (class-ref-class class) derived-classes)))
(when (not (null? constrs))
(dolist (tyvar tyvars)
(when (not (memq tyvar tyvars-referenced))
(signal-unreferenced-tyvar-arg tyvar))))
(resolve-signature-aux tyvars context)
;; This computes a signature for the datatype as a whole.
(let ((gtype (ast->gtype context simple)))
;; This sets the signatures for the constructors
(dolist (con constr-defs)
(let* ((con-type (**arrow-type/l (append (con-types con)
(list simple))))
(con-context (restrict-context
context (tuple-2-2 (assq con all-con-vars))))
(con-signature (ast->gtype con-context con-type)))
(setf (con-signature con) con-signature)))
(update-slots algdata def
(n-constr (length constrs))
(constrs constr-defs)
(context context)
(tyvars tyvars)
(signature gtype)
(classes '())
(enum? enum?)
(tuple? (and (not (null? constrs)) (null? (cdr constrs))))
(real-tuple? '#f)
(deriving derived-classes)
))
(process-alg-annotations def)
def))))
(define (process-alg-strictness-annotation anns)
(let ((res '#f))
(dolist (a anns)
(if (and (annotation-value? a)
(eq? (annotation-value-name a) '|STRICT|)
(null? (annotation-value-args a)))
(setf res '#t)
(signal-unknown-annotation a)))
res))
(define (get-constr-strictness anns all-strict?)
(let ((res all-strict?))
(dolist (a anns)
(cond ((annotation-value? a)
(if (and (eq? (annotation-value-name a) '|STRICT|)
(null? (annotation-value-args a)))
(setf res '#t)
(signal-unknown-annotation a)))
(else (signal-unknown-annotation a))))
res))
(define (process-alg-annotations alg)
(dolist (a (module-annotations *module*))
(when (and (annotation-value? a)
(or (eq? (annotation-value-name a) '|ImportLispType|)
(eq? (annotation-value-name a) '|ExportLispType|))
(assq (def-name alg) (car (annotation-value-args a))))
(if (eq? (annotation-value-name a) '|ImportLispType|)
(setf (algdata-implemented-by-lisp? alg) '#t)
(setf (algdata-export-to-lisp? alg) '#t))
(let ((constrs (tuple-2-2 (assq (def-name alg)
(car (annotation-value-args a))))))
(dolist (c constrs)
(process-annotated-constr
alg
(lookup-alg-constr (tuple-2-1 c) (algdata-constrs alg))
(tuple-2-2 c)))))))
(define (lookup-alg-constr name constrs)
(if (null? constrs)
(fatal-error 'bad-constr-name "Constructor ~A not in algdata~%"
name)
(if (eq? name (def-name (car constrs)))
(car constrs)
(lookup-alg-constr name (cdr constrs)))))
(define (process-annotated-constr alg con lisp-fns)
;; For nullary tuples, allow a single annotation to represent a constant
;; and generate the test function by default.
(when (and (eqv? (con-arity con) 0)
lisp-fns
(null? (cdr lisp-fns)))
(push `(lambda (x) (eq? x ,(car lisp-fns))) lisp-fns))
;; Insert an implicit test function for tuples (never used anyway!)
(when (and (algdata-tuple? alg)
(eqv? (+ 1 (con-arity con)) (length lisp-fns)))
(push '(lambda (x) '#t) lisp-fns))
(when (or (not (null? (con-lisp-fns con)))
(not (eqv? (length lisp-fns) (+ 2 (con-arity con)))))
(fatal-error 'bad-constr-annotation
"Bad annotation for ~A in ~A~%" con alg))
(setf (con-lisp-fns con) lisp-fns))
(define (signal-unknown-annotation a)
(recoverable-error 'bad-annotation "Bad or misplaced annotation: ~A%"
a))
(define (restrict-context context vars)
(if (null? context)
'()
(let ((rest (restrict-context (cdr context) vars)))
(if (memq (context-tyvar (car context)) vars)
(cons (car context) rest)
rest))))
(define (signal-bad-algdata-tyvar tyvar)
(phase-error 'bad-algdata-tyvar
"~a is referenced on the right-hand side of a data type declaration,~%~
but is not bound as a type variable."
tyvar))
(define (signal-unreferenced-tyvar-arg tyvar)
(phase-error 'unreferenced-tyvar-arg
"~a is bound as a type variable in a data type declaration,~%~
but is not referenced on the right-hand side."
tyvar))
;;; Synonyms
;;; Errors detected:
(define (synonym->def synonym-decl)
(remember-context synonym-decl
(with-slots synonym-decl (simple body) synonym-decl
(let* ((def (tycon-def simple))
(tyvars (simple-tyvar-list simple))
(tyvars-referenced (resolve-type body)))
(dolist (v tyvars)
(if (not (memq v tyvars-referenced))
(signal-unreferenced-synonym-arg v)))
(dolist (v tyvars-referenced)
(if (not (memq v tyvars))
(signal-bad-synonym-tyvar v)))
(update-slots synonym def
(args tyvars)
(body body))
(push (cons def (gather-synonyms body '())) *synonym-refs*)
def))))
(define (signal-bad-synonym-tyvar tyvar)
(phase-error 'bad-synonym-tyvar
"~a is referenced on the right-hand side of a type synonym declaration,~%~
but is not bound as a type variable."
tyvar))
(define (signal-unreferenced-synonym-arg tyvar)
(haskell-warning 'unreferenced-synonym-arg
"~a is bound as a type variable in a type synonym declaration,~%~
but is not referenced on the right-hand side."
tyvar))
(define (gather-synonyms type acc)
(cond ((tyvar? type)
acc)
((and (synonym? (tycon-def type))
(eq? *unit* (def-unit (tycon-def type))))
(gather-synonyms/list (tycon-args type)
(cons (tycon-def type) acc)))
(else
(gather-synonyms/list (tycon-args type) acc))))
(define (gather-synonyms/list types acc)
(if (null? types)
acc
(gather-synonyms/list (cdr types) (gather-synonyms (car types) acc))))
|
