4 (and (list? t) (eq? (car t) 'abs)))
7 (and (not (list? t)) (not (concrete? t)) (symbol? t)))
16 (define (pretty-type t)
20 (string-append "(" (pretty-type (cadr t)) ")")
21 (pretty-type (cadr t)))
23 (pretty-type (caddr t))))
24 (else (symbol->string t))))
27 (define (env-lookup env n)
28 (if (null? env) (error #f "empty env") ; it's a type equality
29 (if (eq? (caar env) n)
31 (env-lookup (cdr env) n))))
33 (define (env-insert env n t)
34 (cons (cons n t) env))
41 (set! cur-tvar (+ cur-tvar 1))
43 (string-append "t" (number->string (- cur-tvar 1))))))
50 (define (normalize prog) ; (+ a b) -> ((+ a) b)
53 ; (lambda (x y) (+ x y)) -> (lambda (x) (lambda (y) (+ x y)))
54 (if (> (length (lambda-args prog)) 1)
55 (list 'lambda (list (car (lambda-args prog)))
56 (normalize (list 'lambda (cdr (lambda-args prog)) (caddr prog))))
57 (list 'lambda (lambda-args prog) (normalize (caddr prog)))))
59 (if (null? (cddr prog))
60 `(,(normalize (car prog)) ,(normalize (cadr prog))) ; (f a)
61 (normalize `(,(list (normalize (car prog)) (normalize (cadr prog)))
62 ,@(cddr prog))))) ; (f a b)
65 (map (lambda (x) `(,(car x) ,(normalize (cadr x))))
67 (map normalize (let-body prog))))
68 (else (ast-traverse normalize prog))))
70 (define (builtin-type x)
72 ('+ '(abs int (abs int int)))
73 ('- '(abs int (abs int int)))
74 ('* '(abs int (abs int int)))
76 ('= '(abs int (abs int bool)))
77 ('bool->int '(abs bool int))
78 ('print '(abs string void))
81 ; we typecheck the lambda calculus only (only single arg lambdas)
82 (define (typecheck prog)
84 ;; (display "check: ")
92 ('int-literal (list '() 'int))
93 ('bool-literal (list '() 'bool))
94 ('string-literal (list '() 'string))
95 ('builtin (list '() (builtin-type x)))
98 (let* ((cond-type-res (check env (cadr x)))
99 (then-type-res (check env (caddr x)))
100 (else-type-res (check env (cadddr x)))
101 (then-eq-else-cs (~ (cadr then-type-res)
102 (cadr else-type-res)))
105 (consolidate (car else-type-res)
107 (return-type (substitute cs (cadr then-type-res))))
108 (when (not (eqv? (cadr cond-type-res) 'bool))
109 (error #f "if condition isn't bool"))
110 (list cs return-type)))
112 ('var (list '() (env-lookup env x)))
114 ; takes in the current environment and a scc
115 ; returns new environment with scc's types added in
116 (let* ([components (reverse (sccs (graph (let-bindings x))))]
120 ; create a new env with tvars for each component
122 ; scc-env = ((x . t0) (y . t1))
126 (env-insert acc c (fresh-tvar)))
128 ; typecheck each component
132 (let ([body (cadr (assoc c (let-bindings x)))])
133 (check scc-env body)))
135 ; collect all the constraints in the scc
141 (consolidate (car res)
142 ; unify with tvars from scc-env
144 (~ (cadr res) (env-lookup scc-env c)))))
145 '() type-results comps)]
146 ; substitute *only* the bindings in this scc
149 (if (memv (car x) comps)
150 (cons (car x) (substitute cs (cdr x)))
154 [new-env (fold-left process-component env components)])
155 (check new-env (last (let-body x)))))
158 (let* [(new-env (env-insert env (lambda-arg x) (fresh-tvar)))
160 (body-type-res (check new-env (lambda-body x)))
161 (cs (car body-type-res))
162 (subd-env (substitute-env (car body-type-res) new-env))
163 (arg-type (env-lookup subd-env (lambda-arg x)))
164 (resolved-arg-type (substitute cs arg-type))]
165 ;; (display "lambda:\n\t")
170 ;; (display resolved-arg-type)
172 (list (car body-type-res)
175 (cadr body-type-res)))))
178 (if (eqv? (car x) (cadr x))
179 ; recursive function (f f)
180 (let* [(func-type (env-lookup env (car x)))
181 (return-type (fresh-tvar))
182 (other-func-type `(abs ,func-type ,return-type))
183 (cs (~ func-type other-func-type))
184 (resolved-return-type (substitute cs return-type))]
185 (list cs resolved-return-type))
188 (let* ((arg-type-res (check env (cadr x)))
189 (arg-type (cadr arg-type-res))
190 (func-type-res (check env (car x)))
191 (func-type (cadr func-type-res))
200 (consolidate func-c (car arg-type-res))
201 (car func-type-res)))
203 (resolved-func-type (substitute cs func-type))
204 (resolved-return-type (caddr resolved-func-type)))
205 ;; (display "app:\n")
208 ;; (display func-type)
210 ;; (display resolved-func-type)
212 ;; (display arg-type-res)
214 (if (abs? resolved-func-type)
215 (let ((return-type (substitute cs (caddr resolved-func-type))))
216 (list cs return-type))
217 (error #f "not a function"))))))))
218 ;; (display "result of ")
221 ;; (display (pretty-type (cadr res)))
223 ;; (display (car res))
226 (cadr (check '() (normalize prog))))
228 ; returns a list of pairs of constraints
230 (let ([res (unify? a b)])
234 (format "couldn't unify ~a ~~ ~a" a b)))))
237 (cond [(eq? a b) '()]
238 [(or (tvar? a) (tvar? b)) (list (list a b))]
239 [(and (abs? a) (abs? b))
240 (let* [(arg-cs (unify? (cadr a) (cadr b)))
241 (body-cs (unify? (substitute arg-cs (caddr a))
242 (substitute arg-cs (caddr b))))]
243 (consolidate arg-cs body-cs))]
246 ; TODO: what's the most appropriate substitution?
247 ; should all constraints just be limited to a pair?
248 ; this is currently horrific and i don't know what im doing.
249 ; should probably use ast-find here or during consolidation
250 ; to detect substitutions more than one layer deep
251 ; e.g. (abs t1 int) ~ (abs bool int)
252 ; substituting these constraints with t1 should resolve t1 with bool
253 (define (substitute cs t)
254 ; gets the first concrete type
255 ; otherwise returns the last type variable
257 ; removes t itself from cs, to prevent infinite recursion
260 (filter (lambda (x) (not (eqv? t x))) c))
263 (define (get-concrete c)
264 (let [(last (null? (cdr c)))]
265 (if (not (tvar? (car c)))
267 (substitute cs-without-t (car c))
271 (get-concrete (cdr c))))))
275 (substitute cs (cadr t))
276 (substitute cs (caddr t))))
285 (define (substitute-env cs env)
286 (map (lambda (x) (cons (car x) (substitute cs (cdr x)))) env))
288 (define (consolidate x y)
292 (else (if (member (car b) a)
294 (cons (car b) (merge a (cdr b)))))))
295 (define (overlap? a b)
296 (if (or (null? a) (null? b))
298 (if (fold-left (lambda (acc v)
299 (or acc (eq? v (car a))))
302 (overlap? (cdr a) b))))
317 (filter (lambda (b) (not (eq? b (cdr merged)))) x)
320 (consolidate removed (cons (car merged) (cdr y)))
321 (consolidate (cons a x) (cdr y)))))))
323 ; a1 -> a2 ~ a3 -> a4;
324 ; a1 -> a2 !~ bool -> bool
325 ; basically can the tvars be renamed
326 (define (types-equal? x y)
327 (let ([cs (unify? x y)])
332 (if (tvar? c) acc #f))]
333 [test (lambda (acc c)
335 (fold-left test-kind #t c) ; check only tvar substitutions
336 (<= (length c) 2)))]) ; check maximum 2 subs per equality group
337 (fold-left test #t cs)))))
339 ; input: a list of binds ((x . y) (y . 3))
340 ; returns: pair of verts, edges ((x y) . (x . y))
342 (define (go bs orig-bs)
343 (define (find-refs prog)
347 ; only count a reference if its a binding
348 ['var (if (assoc x orig-bs) (list x) '())]
353 (let* [(bind (car bs))
356 (refs (find-refs (cdr bind)))
357 (edges (map (lambda (x) (cons vert x))
360 (rest (if (null? (cdr bs))
362 (go (cdr bs) orig-bs)))
363 (total-verts (cons vert (car rest)))
364 (total-edges (append edges (cdr rest)))]
365 (cons total-verts total-edges))))
368 (define (successors graph v)
372 (if (eqv? v (caar E))
373 (cons (cdar E) (go v (cdr E)))
377 ; takes in a graph (pair of vertices, edges)
378 ; returns a list of strongly connected components
380 ; ((x y w) . ((x . y) (x . w) (w . x))
390 ; this uses tarjan's algorithm, to get reverse
391 ; topological sorting for free
394 (let* ([indices (make-hash-table)]
395 [lowlinks (make-hash-table)]
396 [on-stack (make-hash-table)]
402 (get-hash-table indices v #f))
404 (get-hash-table lowlinks v #f))
410 (put-hash-table! indices v current)
411 (put-hash-table! lowlinks v current)
412 (set! current (+ current 1))
414 (put-hash-table! on-stack v #t)
418 (if (not (hashtable-contains? indices w))
419 ; successor w has not been visited, recurse
422 (put-hash-table! lowlinks
424 (min (lowlink v) (lowlink w))))
425 ; successor w has been visited
426 (when (get-hash-table on-stack w #f)
427 (put-hash-table! lowlinks v (min (lowlink v) (index w))))))
428 (successors graph v))
430 (when (= (index v) (lowlink v))
433 (let ([w (pop! stack)])
434 (put-hash-table! on-stack w #f)
437 (cons w (new-scc)))))])
438 (set! result (cons scc result))))))])
441 (when (not (hashtable-contains? indices v)) ; v.index == -1