;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; strips pretty-types from source code
;; returns a cons of (the-new-ast any-explicit-types)
;;
(define impc:ti:get-var-types
(lambda (ast)
(let* ((types '())
(f (lambda (ast)
;;(print 'ast: ast 'types: types)
(cond ((null? ast) '())
((atom? ast) ast)
((member (car ast) *impc:lambdaslist*)
(list* (car ast) ;; 'lambda
(map (lambda (a)
(if (and (list? a)
(eq? (car a) '*colon-hook*))
(impc:compiler:print-double-colon-error (caddr a)))
(if (string-contains? (symbol->string a) ":")
(let ((t (regex:type-split (symbol->string a) ":")))
(if (regex:match? (cadr t) "^\\<|\\[")
(if (not (regex:match? (cadr t) "\\>|\\]"))
(impc:compiler:print-bad-type-error (cadr t))))
(set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
(string->symbol (car t)))
a))
(cadr ast))
(f (cddr ast))))
((member (car ast) *impc:letslist*)
(list* (car ast)
(map (lambda (a)
(if (or (atom? a)
(null? (cdr a))
(list? (car a))
(> (length (cdr a)) 1))
(impc:compiler:print-badly-formed-expression-error 'let a))
(if (and (list? (car a))
(eq? (car (car a)) '*colon-hook*))
(impc:compiler:print-double-colon-error (caddr (car a))))
(if (string-contains? (symbol->string (car a)) ":")
(let ((t (regex:type-split (symbol->string (car a)) ":")))
(if (regex:match? (cadr t) "^\\<|\\[")
(if (not (regex:match? (cadr t) "\\>|\\]"))
(impc:compiler:print-bad-type-error (cadr t))))
(set! types (cons (cons (string->symbol (car t)) (string->symbol (cadr t))) types))
(list (string->symbol (car t)) (car (f (cdr a)))))
(list (car a) (car (f (cdr a))))))
(cadr ast))
(f (cddr ast))))
((pair? ast)
(cons (f (car ast))
(f (cdr ast))))))))
(cons (f ast) types))))