;; run the type checker
;; if we fail to unify completely the first time
;; try some possible substitutions!
(define impc:ti:run-type-check*
(lambda (vars forced-types ast . cnt)
(set! *impc:ti:nativef-generics:calls* 0)
(set! *impc:ti:type-check:calls* 0)
;; (println '------------------------------------)
;; (println 'run-type-check*: (caaadr ast))
;; (println 'forced-types* forced-types)
;; (println 'ast: ast)
;; (println 'vars*: vars)
(define *impc:ti:nativef-generics-recurse-test* 0)
(set! *impc:ti:type-check-function-symbol* (caaadr ast))
(set! *impc:ti:type-check-function-symbol-short*
(string->symbol
(car (regex:split (symbol->string *impc:ti:type-check-function-symbol*) "(_poly_)|(_adhoc_)"))))
;; (if (null? cnt) (sys:clear-log-view))
(let* ((fvars (map (lambda (t) ;; add any forced-type values to vars
(if (assoc-strcmp (car t) forced-types)
(let ((tt (cdr (assoc-strcmp (car t) forced-types))))
(cons (car t) (list tt)))
t))
vars))
;; (lll (println 'vars1: vars))
(kts (map (lambda (x) (car x)) forced-types)) ;; just need symbols from forced-types
;; fvars gets modified 'in place' during this next
;; operation
(t1 (clock:clock))
(ret (impc:ti:type-check ast fvars kts #f))
;; (llllllll (println 'pre-unified-vars: fvars))
(t2 (clock:clock))
(u1 (impc:ti:unify fvars))
(u (cl:remove-if (lambda (x)
(and (not (impc:ir:type? (cdr x)))
(regex:match? (symbol->string (car x)) "(^!|[A-Za-z]\\:\\<|[A-Za-z]{)")))
u1))
(t3 (clock:clock))
;; (lllll (println 'post-unified-vars: u))
(t (impc:ti:unity? u))
(t4 (clock:clock))
;; (lllllll (println (println 'cccccc)))
(tt (cl:every (lambda (x) x) t))
(a (if tt #t
(impc:ti:find-unresolved-simple-types u))))
;(println 'fvars: fvars)
;(println 'types: u)
(if *impc:ti:print-unifications* (println 'tirun:> a '-> u))