{"slug": "scheme-impl-of-hindley-milner-type-inference-based-on-milner-s-algorithm-w-and", "title": "scheme impl of hindley–milner type inference based on milner's algorithm w and the damas–milner principal type scheme result.", "summary": "A developer implemented Hindley-Milner type inference in Scheme, based on Milner's Algorithm W and the Damas-Milner principal type scheme. The implementation models monotypes and polymorphic type schemes explicitly, deriving types through constraint generation and most-general unification, with extensions for tuples, lists, and letrec.", "body_md": "| ;; based on: | |\n| ;; | |\n| ;; robin milner, \"a theory of type polymorphism in programming\", | |\n| ;; journal of computer and system sciences 17(3), 348–375, 1978 | |\n| ;; | |\n| ;; paper: | |\n| ;; https://www.pure.ed.ac.uk/ws/portalfiles/portal/15143545/1_s2.0_0022000078900144_main.pdf | |\n| ;; | |\n| ;; luis damas and robin milner, \"principal type-schemes for functional | |\n| ;; programs\", popl '82, 207–212, 1982 | |\n| ;; | |\n| ;; paper: | |\n| ;; https://steshaw.org/hm/milner-damas.pdf | |\n| ;; | |\n| ;; this is an adaptation of milners algorithm w for a small ml-like | |\n| ;; language represented directly as scheme s-expressions | |\n| ;; | |\n| ;; the central judgement is: | |\n| ;; | |\n| ;; w(gamma, e) = (s, tau) | |\n| ;; | |\n| ;; gamma is the typing environment, e is the expression, s is the | |\n| ;; substitution produced by inference and tau is the inferred monotype | |\n| ;; | |\n| ;; unknown types are represented by fresh metavariables and application | |\n| ;; introduces a fresh result variable and generates the constraint | |\n| ;; | |\n| ;; tau1 ~ tau2 -> alpha | |\n| ;; | |\n| ;; which is solved by unification. substitutions are composed as w | |\n| ;; recursively traverses the term | |\n| ;; | |\n| ;; let-polymorphism is represented explicitly with type schemes: | |\n| ;; | |\n| ;; forall a1 ... an. tau | |\n| ;; | |\n| ;; variables free in tau but not in gamma are generalised at let | |\n| ;; bindings. every later use is instantiated with fresh metavariables. | |\n| ;; this is the machinery that gives the usual principal types for | |\n| ;; expressions such as: | |\n| ;; | |\n| ;; let id = fun x -> x in | |\n| ;; (id 1, id true) | |\n| ;; | |\n| ;; whose inferred result is: | |\n| ;; | |\n| ;; int * bool | |\n| ;; | |\n| ;; while: | |\n| ;; | |\n| ;; id : forall a. a -> a | |\n| ;; | |\n| ;; remains polymorphic | |\n| ;; | |\n| ;; unification computes a most-general unifier as the occurs check rejects | |\n| ;; recursive equations such as: | |\n| ;; | |\n| ;; a ~ a -> b | |\n| ;; | |\n| ;; which would otherwise describe an infinite type | |\n| ;; | |\n| ;; the damas–milner result concerns principal type-schemes: for the | |\n| ;; relevant purely applicative ml fragment, the inferred scheme is | |\n| ;; principal, meaning every other valid typing is an instance of it | |\n| ;; | |\n| ;; this impl extends the small core with tuples, lists, | |\n| ;; primitive operators, sequencing, and letrec. these are impl | |\n| ;; extensions using the same inference machinery rather than a claim that | |\n| ;; every surface construct below appears verbatim in milner's presentation | |\n| ;; | |\n| ;; recursive bindings use a provisional monotype, constrain it against | |\n| ;; the inferred definition, and only then generalise the resulting type | |\n| ;; | |\n| ;; supported expressions: | |\n| ;; | |\n| ;; 42 | |\n| ;; #t | |\n| ;; #f | |\n| ;; x | |\n| ;; (lambda (x) e) | |\n| ;; (f x) | |\n| ;; (let ((x e)) body) | |\n| ;; (letrec ((x e)) body) | |\n| ;; (if c t e) | |\n| ;; (begin e1 e2 ...) | |\n| ;; (tuple e1 e2 ...) | |\n| ;; nil | |\n| ;; (cons x xs) | |\n| ;; (head xs) | |\n| ;; (tail xs) | |\n| ;; (null? xs) | |\n| ;; (+ x y) | |\n| ;; (- x y) | |\n| ;; (* x y) | |\n| ;; (/ x y) | |\n| ;; (< x y) | |\n| ;; (<= x y) | |\n| ;; (> x y) | |\n| ;; (>= x y) | |\n| ;; (= x y) | |\n| ;; (and x y) | |\n| ;; (or x y) | |\n| ;; (not x) | |\n| (define (type-error tag . args) | |\n| (apply error (cons tag args))) | |\n| (define (member-symbol? x xs) | |\n| (cond | |\n| ((null? xs) #f) | |\n| ((eq? x (car xs)) #t) | |\n| (else (member-symbol? x (cdr xs))))) | |\n| (define (filter-list p xs) | |\n| (cond | |\n| ((null? xs) '()) | |\n| ((p (car xs)) | |\n| (cons (car xs) | |\n| (filter-list p (cdr xs)))) | |\n| (else | |\n| (filter-list p (cdr xs))))) | |\n| (define (fold-left f acc xs) | |\n| (if (null? xs) | |\n| acc | |\n| (fold-left f | |\n| (f acc (car xs)) | |\n| (cdr xs)))) | |\n| (define (set-add x xs) | |\n| (if (member-symbol? x xs) | |\n| xs | |\n| (cons x xs))) | |\n| (define (set-union xs ys) | |\n| (fold-left | |\n| (lambda (acc x) | |\n| (set-add x acc)) | |\n| ys | |\n| xs)) | |\n| (define (set-difference xs ys) | |\n| (filter-list | |\n| (lambda (x) | |\n| (not (member-symbol? x ys))) | |\n| xs)) | |\n| (define (string-join xs separator) | |\n| (cond | |\n| ((null? xs) \"\") | |\n| ((null? (cdr xs)) (car xs)) | |\n| (else | |\n| (string-append | |\n| (car xs) | |\n| separator | |\n| (string-join (cdr xs) separator))))) | |\n| (define *next-type-variable* 0) | |\n| (define (reset-type-variables!) | |\n| (set! *next-type-variable* 0)) | |\n| (define (fresh-type-variable) | |\n| (let ((n *next-type-variable*)) | |\n| (set! *next-type-variable* | |\n| (+ n 1)) | |\n| (string->symbol | |\n| (string-append \"t\" | |\n| (number->string n))))) | |\n| (define type-int 'int) | |\n| (define type-bool 'bool) | |\n| (define type-unit 'unit) | |\n| (define (type-arrow from to) | |\n| (list '-> from to)) | |\n| (define (type-list element) | |\n| (list 'list element)) | |\n| (define (type-tuple elements) | |\n| (cons 'tuple elements)) | |\n| (define (type-arrow? type) | |\n| (and (pair? type) | |\n| (eq? (car type) '->) | |\n| (= (length type) 3))) | |\n| (define (type-list? type) | |\n| (and (pair? type) | |\n| (eq? (car type) 'list) | |\n| (= (length type) 2))) | |\n| (define (type-tuple? type) | |\n| (and (pair? type) | |\n| (eq? (car type) 'tuple))) | |\n| (define (primitive-type? type) | |\n| (and (symbol? type) | |\n| (or (eq? type 'int) | |\n| (eq? type 'bool) | |\n| (eq? type 'unit)))) | |\n| (define (type-variable? type) | |\n| (and (symbol? type) | |\n| (not (primitive-type? type)))) | |\n| (define empty-substitution '()) | |\n| (define (substitution-lookup variable substitution) | |\n| (let ((binding (assq variable substitution))) | |\n| (if binding | |\n| (cdr binding) | |\n| #f))) | |\n| (define (apply-substitution type substitution) | |\n| (cond | |\n| ((type-variable? type) | |\n| (let ((replacement | |\n| (substitution-lookup | |\n| type | |\n| substitution))) | |\n| (if replacement | |\n| (apply-substitution | |\n| replacement | |\n| substitution) | |\n| type))) | |\n| ((type-arrow? type) | |\n| (type-arrow | |\n| (apply-substitution | |\n| (cadr type) | |\n| substitution) | |\n| (apply-substitution | |\n| (caddr type) | |\n| substitution))) | |\n| ((type-list? type) | |\n| (type-list | |\n| (apply-substitution | |\n| (cadr type) | |\n| substitution))) | |\n| ((type-tuple? type) | |\n| (type-tuple | |\n| (map | |\n| (lambda (element) | |\n| (apply-substitution | |\n| element | |\n| substitution)) | |\n| (cdr type)))) | |\n| (else | |\n| type))) | |\n| (define (compose-substitutions s1 s2) | |\n| (append | |\n| (map | |\n| (lambda (binding) | |\n| (cons | |\n| (car binding) | |\n| (apply-substitution | |\n| (cdr binding) | |\n| s1))) | |\n| s2) | |\n| s1)) | |\n| (define (free-type-variables type) | |\n| (cond | |\n| ((type-variable? type) | |\n| (list type)) | |\n| ((type-arrow? type) | |\n| (set-union | |\n| (free-type-variables | |\n| (cadr type)) | |\n| (free-type-variables | |\n| (caddr type)))) | |\n| ((type-list? type) | |\n| (free-type-variables | |\n| (cadr type))) | |\n| ((type-tuple? type) | |\n| (fold-left | |\n| (lambda (acc element) | |\n| (set-union | |\n| acc | |\n| (free-type-variables element))) | |\n| '() | |\n| (cdr type))) | |\n| (else | |\n| '()))) | |\n| (define (make-scheme variables body) | |\n| (list 'forall variables body)) | |\n| (define (scheme-variables scheme) | |\n| (cadr scheme)) | |\n| (define (scheme-body scheme) | |\n| (caddr scheme)) | |\n| (define (free-type-variables-scheme scheme) | |\n| (set-difference | |\n| (free-type-variables | |\n| (scheme-body scheme)) | |\n| (scheme-variables scheme))) | |\n| (define empty-environment '()) | |\n| (define (environment-extend environment name scheme) | |\n| (cons | |\n| (cons name scheme) | |\n| environment)) | |\n| (define (environment-lookup environment name) | |\n| (let ((binding | |\n| (assq name environment))) | |\n| (if binding | |\n| (cdr binding) | |\n| (type-error | |\n| 'unbound-variable | |\n| name)))) | |\n| (define (free-type-variables-environment environment) | |\n| (if (null? environment) | |\n| '() | |\n| (set-union | |\n| (free-type-variables-scheme | |\n| (cdar environment)) | |\n| (free-type-variables-environment | |\n| (cdr environment))))) | |\n| (define (strip-quantified-variables substitution variables) | |\n| (filter-list | |\n| (lambda (binding) | |\n| (not | |\n| (member-symbol? | |\n| (car binding) | |\n| variables))) | |\n| substitution)) | |\n| (define (apply-substitution-scheme scheme substitution) | |\n| (make-scheme | |\n| (scheme-variables scheme) | |\n| (apply-substitution | |\n| (scheme-body scheme) | |\n| (strip-quantified-variables | |\n| substitution | |\n| (scheme-variables scheme))))) | |\n| (define (apply-substitution-environment environment substitution) | |\n| (map | |\n| (lambda (binding) | |\n| (cons | |\n| (car binding) | |\n| (apply-substitution-scheme | |\n| (cdr binding) | |\n| substitution))) | |\n| environment)) | |\n| (define (generalise environment type) | |\n| (make-scheme | |\n| (set-difference | |\n| (free-type-variables type) | |\n| (free-type-variables-environment | |\n| environment)) | |\n| type)) | |\n| (define (instantiate scheme) | |\n| (let ((substitution | |\n| (map | |\n| (lambda (variable) | |\n| (cons variable | |\n| (fresh-type-variable))) | |\n| (scheme-variables scheme)))) | |\n| (apply-substitution | |\n| (scheme-body scheme) | |\n| substitution))) | |\n| (define (occurs-in? variable type) | |\n| (member-symbol? | |\n| variable | |\n| (free-type-variables type))) | |\n| (define (bind variable type) | |\n| (cond | |\n| ((equal? variable type) | |\n| empty-substitution) | |\n| ((occurs-in? variable type) | |\n| (type-error | |\n| 'occurs-check | |\n| variable | |\n| type)) | |\n| (else | |\n| (list | |\n| (cons variable type))))) | |\n| (define (unify-sequence lefts rights) | |\n| (cond | |\n| ((null? lefts) | |\n| (if (null? rights) | |\n| empty-substitution | |\n| (type-error | |\n| 'arity-mismatch))) | |\n| ((null? rights) | |\n| (type-error | |\n| 'arity-mismatch)) | |\n| (else | |\n| (let* ((s1 | |\n| (unify | |\n| (car lefts) | |\n| (car rights))) | |\n| (s2 | |\n| (unify-sequence | |\n| (map | |\n| (lambda (type) | |\n| (apply-substitution type s1)) | |\n| (cdr lefts)) | |\n| (map | |\n| (lambda (type) | |\n| (apply-substitution type s1)) | |\n| (cdr rights))))) | |\n| (compose-substitutions | |\n| s2 | |\n| s1))))) | |\n| (define (unify left right) | |\n| (cond | |\n| ((type-variable? left) | |\n| (bind left right)) | |\n| ((type-variable? right) | |\n| (bind right left)) | |\n| ((and (primitive-type? left) | |\n| (primitive-type? right) | |\n| (eq? left right)) | |\n| empty-substitution) | |\n| ((and (type-arrow? left) | |\n| (type-arrow? right)) | |\n| (let* ((s1 | |\n| (unify | |\n| (cadr left) | |\n| (cadr right))) | |\n| (s2 | |\n| (unify | |\n| (apply-substitution | |\n| (caddr left) | |\n| s1) | |\n| (apply-substitution | |\n| (caddr right) | |\n| s1)))) | |\n| (compose-substitutions | |\n| s2 | |\n| s1))) | |\n| ((and (type-list? left) | |\n| (type-list? right)) | |\n| (unify | |\n| (cadr left) | |\n| (cadr right))) | |\n| ((and (type-tuple? left) | |\n| (type-tuple? right)) | |\n| (if (= (length left) | |\n| (length right)) | |\n| (unify-sequence | |\n| (cdr left) | |\n| (cdr right)) | |\n| (type-error | |\n| 'tuple-arity-mismatch | |\n| left | |\n| right))) | |\n| (else | |\n| (type-error | |\n| 'cannot-unify | |\n| left | |\n| right)))) | |\n| (define (mono type) | |\n| (make-scheme '() type)) | |\n| (define (binary-type left right result) | |\n| (type-arrow | |\n| left | |\n| (type-arrow | |\n| right | |\n| result))) | |\n| (define (unary-type argument result) | |\n| (type-arrow | |\n| argument | |\n| result)) | |\n| (define (initial-environment) | |\n| (let ((environment empty-environment)) | |\n| ;; integer arithmetic | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| '+ | |\n| (mono | |\n| (binary-type | |\n| 'int | |\n| 'int | |\n| 'int)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| '- | |\n| (mono | |\n| (binary-type | |\n| 'int | |\n| 'int | |\n| 'int)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| '* | |\n| (mono | |\n| (binary-type | |\n| 'int | |\n| 'int | |\n| 'int)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| '/ | |\n| (mono | |\n| (binary-type | |\n| 'int | |\n| 'int | |\n| 'int)))) | |\n| (for-each | |\n| (lambda (operator) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| operator | |\n| (mono | |\n| (binary-type | |\n| 'int | |\n| 'int | |\n| 'bool))))) | |\n| '(< <= > >= =)) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'and | |\n| (mono | |\n| (binary-type | |\n| 'bool | |\n| 'bool | |\n| 'bool)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'or | |\n| (mono | |\n| (binary-type | |\n| 'bool | |\n| 'bool | |\n| 'bool)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'not | |\n| (mono | |\n| (unary-type | |\n| 'bool | |\n| 'bool)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'nil | |\n| (make-scheme | |\n| '(a) | |\n| (type-list 'a)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'cons | |\n| (make-scheme | |\n| '(a) | |\n| (binary-type | |\n| 'a | |\n| (type-list 'a) | |\n| (type-list 'a))))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'head | |\n| (make-scheme | |\n| '(a) | |\n| (unary-type | |\n| (type-list 'a) | |\n| 'a)))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'tail | |\n| (make-scheme | |\n| '(a) | |\n| (unary-type | |\n| (type-list 'a) | |\n| (type-list 'a))))) | |\n| (set! environment | |\n| (environment-extend | |\n| environment | |\n| 'null? | |\n| (make-scheme | |\n| '(a) | |\n| (unary-type | |\n| (type-list 'a) | |\n| 'bool)))) | |\n| environment)) | |\n| (define (lambda-expression? expression) | |\n| (and (pair? expression) | |\n| (eq? (car expression) 'lambda) | |\n| (= (length expression) 3) | |\n| (pair? (cadr expression)) | |\n| (= (length (cadr expression)) 1))) | |\n| (define (let-expression? expression) | |\n| (and (pair? expression) | |\n| (eq? (car expression) 'let) | |\n| (= (length expression) 3))) | |\n| (define (letrec-expression? expression) | |\n| (and (pair? expression) | |\n| (eq? (car expression) 'letrec) | |\n| (= (length expression) 3))) | |\n| (define (if-expression? expression) | |\n| (and (pair? expression) | |\n| (eq? (car expression) 'if) | |\n| (= (length expression) 4))) | |\n| (define (begin-expression? expression) | |\n| (and (pair? expression) | |\n| (eq? (car expression) 'begin) | |\n| (>= (length expression) 2))) | |\n| (define (tuple-expression? expression) | |\n| (and (pair? expression) | |\n| (eq? (car expression) 'tuple))) | |\n| (define (operator? expression) | |\n| (and (pair? expression) | |\n| (member-symbol? | |\n| (car expression) | |\n| '(+ - * / < <= > >= = and or not)))) | |\n| (define (curry-application expression) | |\n| (fold-left | |\n| (lambda (operator argument) | |\n| (list operator argument)) | |\n| (car expression) | |\n| (cdr expression))) | |\n| (define (infer environment expression) | |\n| (cond | |\n| ((integer? expression) | |\n| (cons empty-substitution | |\n| type-int)) | |\n| ((boolean? expression) | |\n| (cons empty-substitution | |\n| type-bool)) | |\n| ((symbol? expression) | |\n| (cons empty-substitution | |\n| (instantiate | |\n| (environment-lookup | |\n| environment | |\n| expression)))) | |\n| ((lambda-expression? expression) | |\n| (let* ((name | |\n| (car (cadr expression))) | |\n| (body | |\n| (caddr expression)) | |\n| (argument-type | |\n| (fresh-type-variable)) | |\n| (body-environment | |\n| (environment-extend | |\n| environment | |\n| name | |\n| (mono argument-type))) | |\n| (result | |\n| (infer | |\n| body-environment | |\n| body)) | |\n| (substitution | |\n| (car result)) | |\n| (body-type | |\n| (cdr result))) | |\n| (cons | |\n| substitution | |\n| (type-arrow | |\n| (apply-substitution | |\n| argument-type | |\n| substitution) | |\n| body-type)))) | |\n| ((and (pair? expression) | |\n| (= (length expression) 2)) | |\n| (let* ((function-result | |\n| (infer | |\n| environment | |\n| (car expression))) | |\n| (s1 | |\n| (car function-result)) | |\n| (function-type | |\n| (cdr function-result)) | |\n| (environment-1 | |\n| (apply-substitution-environment | |\n| environment | |\n| s1)) | |\n| (argument-result | |\n| (infer | |\n| environment-1 | |\n| (cadr expression))) | |\n| (s2 | |\n| (car argument-result)) | |\n| (argument-type | |\n| (cdr argument-result)) | |\n| (result-type | |\n| (fresh-type-variable)) | |\n| (s3 | |\n| (unify | |\n| (apply-substitution | |\n| function-type | |\n| s2) | |\n| (type-arrow | |\n| argument-type | |\n| result-type))) | |\n| (substitution | |\n| (compose-substitutions | |\n| s3 | |\n| (compose-substitutions | |\n| s2 | |\n| s1)))) | |\n| (cons | |\n| substitution | |\n| (apply-substitution | |\n| result-type | |\n| s3)))) | |\n| ((if-expression? expression) | |\n| (let* ((condition-result | |\n| (infer | |\n| environment | |\n| (cadr expression))) | |\n| (s1 | |\n| (car condition-result)) | |\n| (condition-type | |\n| (cdr condition-result)) | |\n| (s2 | |\n| (unify | |\n| (apply-substitution | |\n| condition-type | |\n| s1) | |\n| type-bool)) | |\n| (s12 | |\n| (compose-substitutions | |\n| s2 | |\n| s1)) | |\n| (environment-1 | |\n| (apply-substitution-environment | |\n| environment | |\n| s12)) | |\n| (then-result | |\n| (infer | |\n| environment-1 | |\n| (caddr expression))) | |\n| (s3 | |\n| (car then-result)) | |\n| (then-type | |\n| (cdr then-result)) | |\n| (s123 | |\n| (compose-substitutions | |\n| s3 | |\n| s12)) | |\n| (environment-2 | |\n| (apply-substitution-environment | |\n| environment | |\n| s123)) | |\n| (else-result | |\n| (infer | |\n| environment-2 | |\n| (cadddr expression))) | |\n| (s4 | |\n| (car else-result)) | |\n| (else-type | |\n| (cdr else-result)) | |\n| (s5 | |\n| (unify | |\n| (apply-substitution | |\n| then-type | |\n| s4) | |\n| else-type))) | |\n| (cons | |\n| (compose-substitutions | |\n| s5 | |\n| (compose-substitutions | |\n| s4 | |\n| (compose-substitutions | |\n| s3 | |\n| s12))) | |\n| (apply-substitution | |\n| else-type | |\n| s5)))) | |\n| ((let-expression? expression) | |\n| (let* ((bindings | |\n| (cadr expression)) | |\n| (binding | |\n| (if (= (length bindings) 1) | |\n| (car bindings) | |\n| (error | |\n| \"let expects one binding\"))) | |\n| (name | |\n| (car binding)) | |\n| (value | |\n| (cadr binding)) | |\n| (body | |\n| (caddr expression)) | |\n| (value-result | |\n| (infer | |\n| environment | |\n| value)) | |\n| (s1 | |\n| (car value-result)) | |\n| (value-type | |\n| (cdr value-result)) | |\n| (environment-1 | |\n| (apply-substitution-environment | |\n| environment | |\n| s1)) | |\n| (value-type-1 | |\n| (apply-substitution | |\n| value-type | |\n| s1)) | |\n| (scheme | |\n| (generalise | |\n| environment-1 | |\n| value-type-1)) | |\n| (environment-2 | |\n| (environment-extend | |\n| environment-1 | |\n| name | |\n| scheme)) | |\n| (body-result | |\n| (infer | |\n| environment-2 | |\n| body))) | |\n| (cons | |\n| (compose-substitutions | |\n| (car body-result) | |\n| s1) | |\n| (cdr body-result)))) | |\n| ((letrec-expression? expression) | |\n| (let* ((bindings | |\n| (cadr expression)) | |\n| (binding | |\n| (if (= (length bindings) 1) | |\n| (car bindings) | |\n| (error | |\n| \"letrec expects one binding\"))) | |\n| (name | |\n| (car binding)) | |\n| (value | |\n| (cadr binding)) | |\n| (body | |\n| (caddr expression)) | |\n| ;; the recursive name is visible while checking its own | |\n| ;; definition through a provisional monotype | |\n| (provisional-type | |\n| (fresh-type-variable)) | |\n| (environment-1 | |\n| (environment-extend | |\n| environment | |\n| name | |\n| (mono provisional-type))) | |\n| (value-result | |\n| (infer | |\n| environment-1 | |\n| value)) | |\n| (s1 | |\n| (car value-result)) | |\n| (value-type | |\n| (cdr value-result)) | |\n| (s2 | |\n| (unify | |\n| (apply-substitution | |\n| provisional-type | |\n| s1) | |\n| value-type)) | |\n| (s12 | |\n| (compose-substitutions | |\n| s2 | |\n| s1)) | |\n| (environment-2 | |\n| (apply-substitution-environment | |\n| environment | |\n| s12)) | |\n| (final-type | |\n| (apply-substitution | |\n| provisional-type | |\n| s12)) | |\n| (scheme | |\n| (generalise | |\n| environment-2 | |\n| final-type)) | |\n| (environment-3 | |\n| (environment-extend | |\n| environment-2 | |\n| name | |\n| scheme)) | |\n| (body-result | |\n| (infer | |\n| environment-3 | |\n| body))) | |\n| (cons | |\n| (compose-substitutions | |\n| (car body-result) | |\n| s12) | |\n| (cdr body-result)))) | |\n| ((begin-expression? expression) | |\n| (infer-sequence | |\n| environment | |\n| (cdr expression))) | |\n| ((tuple-expression? expression) | |\n| (infer-tuple | |\n| environment | |\n| (cdr expression)) | |\n| ((operator? expression) | |\n| (infer | |\n| environment | |\n| (curry-application expression))) | |\n| ((and (pair? expression) | |\n| (member-symbol? | |\n| (car expression) | |\n| '(cons head tail null?))) | |\n| (infer | |\n| environment | |\n| (curry-application expression))) | |\n| ((and (pair? expression) | |\n| (> (length expression) 2)) | |\n| (infer | |\n| environment | |\n| (curry-application expression))) | |\n| (else | |\n| (type-error | |\n| 'unknown-expression | |\n| expression)))) | |\n| (define (infer-sequence environment expressions) | |\n| (if (null? expressions) | |\n| (cons empty-substitution | |\n| type-unit) | |\n| (let loop ((environment environment) | |\n| (expressions expressions) | |\n| (substitution empty-substitution) | |\n| (last-type type-unit)) | |\n| (if (null? expressions) | |\n| (cons substitution | |\n| last-type) | |\n| (let* ((result | |\n| (infer | |\n| environment | |\n| (car expressions))) | |\n| (s | |\n| (car result)) | |\n| (type | |\n| (cdr result)) | |\n| (combined | |\n| (compose-substitutions | |\n| s | |\n| substitution)) | |\n| (environment-1 | |\n| (apply-substitution-environment | |\n| environment | |\n| combined))) | |\n| (loop | |\n| environment-1 | |\n| (cdr expressions) | |\n| combined | |\n| type)))))) | |\n| (define (infer-tuple environment expressions) | |\n| (let loop ((environment environment) | |\n| (expressions expressions) | |\n| (substitution empty-substitution) | |\n| (types '())) | |\n| (if (null? expressions) | |\n| (cons | |\n| substitution | |\n| (type-tuple | |\n| (reverse types))) | |\n| (let* ((result | |\n| (infer | |\n| environment | |\n| (car expressions))) | |\n| (s | |\n| (car result)) | |\n| (type | |\n| (cdr result)) | |\n| (combined | |\n| (compose-substitutions | |\n| s | |\n| substitution)) | |\n| (environment-1 | |\n| (apply-substitution-environment | |\n| environment | |\n| combined))) | |\n| (loop | |\n| environment-1 | |\n| (cdr expressions) | |\n| combined | |\n| (cons | |\n| (apply-substitution | |\n| type | |\n| combined) | |\n| types)))))) | |\n| (define (type-variable-label n) | |\n| (if (< n 26) | |\n| (string | |\n| (integer->char | |\n| (+ (char->integer #\\a) | |\n| n))) | |\n| (string-append | |\n| (string | |\n| (integer->char | |\n| (+ (char->integer #\\a) | |\n| (modulo n 26)))) | |\n| (number->string | |\n| (quotient n 26))))) | |\n| (define (rename-type-variables type) | |\n| (let ((mapping '()) | |\n| (counter 0)) | |\n| (define (rename variable) | |\n| (let ((binding | |\n| (assq variable mapping))) | |\n| (if binding | |\n| (cdr binding) | |\n| (let ((name | |\n| (string->symbol | |\n| (type-variable-label | |\n| counter)))) | |\n| (set! counter | |\n| (+ counter 1)) | |\n| (set! mapping | |\n| (cons | |\n| (cons variable name) | |\n| mapping)) | |\n| name)))) | |\n| (define (walk t) | |\n| (cond | |\n| ((type-variable? t) | |\n| (rename t)) | |\n| ((type-arrow? t) | |\n| (type-arrow | |\n| (walk (cadr t)) | |\n| (walk (caddr t)))) | |\n| ((type-list? t) | |\n| (type-list | |\n| (walk (cadr t)))) | |\n| ((type-tuple? t) | |\n| (type-tuple | |\n| (map walk | |\n| (cdr t)))) | |\n| (else | |\n| t))) | |\n| (walk type))) | |\n| (define (type->string type) | |\n| (cond | |\n| ((eq? type 'int) | |\n| \"int\") | |\n| ((eq? type 'bool) | |\n| \"bool\") | |\n| ((eq? type 'unit) | |\n| \"unit\") | |\n| ((type-variable? type) | |\n| (symbol->string type)) | |\n| ((type-arrow? type) | |\n| (let ((from (cadr type)) | |\n| (to (caddr type))) | |\n| (string-append | |\n| (if (type-arrow? from) | |\n| (string-append | |\n| \"(\" | |\n| (type->string from) | |\n| \")\") | |\n| (type->string from)) | |\n| \" -> \" | |\n| (type->string to)))) | |\n| ((type-list? type) | |\n| (string-append | |\n| \"[\" | |\n| (type->string | |\n| (cadr type)) | |\n| \"]\")) | |\n| ((type-tuple? type) | |\n| (string-append | |\n| \"(\" | |\n| (string-join | |\n| (map type->string | |\n| (cdr type)) | |\n| \" * \") | |\n| \")\")) | |\n| (else | |\n| (type-error | |\n| 'unknown-type | |\n| type)))) | |\n| (define (infer-principal-type expression) | |\n| (reset-type-variables!) | |\n| (let* ((result | |\n| (infer | |\n| (initial-environment) | |\n| expression)) | |\n| (substitution | |\n| (car result)) | |\n| (type | |\n| (cdr result))) | |\n| (rename-type-variables | |\n| (apply-substitution | |\n| type | |\n| substitution)))) | |\n| (define (infer-type expression) | |\n| (type->string | |\n| (infer-principal-type | |\n| expression))) | |\n| (define (assert-type expression expected) | |\n| (let ((actual | |\n| (infer-type expression))) | |\n| (if (string=? actual expected) | |\n| #t | |\n| (error | |\n| \"expected\" | |\n| expected | |\n| \"got\" | |\n| actual)))) | |\n| (assert-type | |\n| 42 | |\n| \"int\") | |\n| (assert-type | |\n| #t | |\n| \"bool\") | |\n| (assert-type | |\n| '(lambda (x) x) | |\n| \"(a -> a)\") | |\n| (assert-type | |\n| '(lambda (x) | |\n| (lambda (y) | |\n| x)) | |\n| \"(a -> (b -> a))\") | |\n| (assert-type | |\n| '(lambda (f) | |\n| (lambda (x) | |\n| (f x))) | |\n| \"((a -> b) -> (a -> b))\") | |\n| (assert-type | |\n| '(lambda (f) | |\n| (lambda (g) | |\n| (lambda (x) | |\n| (f (g x))))) | |\n| \"((b -> c) -> ((a -> b) -> (a -> c)))\") | |\n| (assert-type | |\n| '(lambda (x) | |\n| (+ x 1)) | |\n| \"(int -> int)\") | |\n| (assert-type | |\n| '(lambda (x) | |\n| (if x 1 0)) | |\n| \"(bool -> int)\") | |\n| (assert-type | |\n| '(let ((id | |\n| (lambda (x) | |\n| x))) | |\n| (tuple | |\n| (id 1) | |\n| (id #t))) | |\n| \"(int * bool)\") | |\n| (assert-type | |\n| '(let ((xs | |\n| (cons 1 nil))) | |\n| (head xs)) | |\n| \"int\") | |\n| (assert-type | |\n| '(lambda (xs) | |\n| (tail xs)) | |\n| \"([a] -> [a])\") | |\n| (assert-type | |\n| '(lambda (xs) | |\n| (null? xs)) | |\n| \"([a] -> bool)\") | |\n| (assert-type | |\n| '(letrec | |\n| ((fact | |\n| (lambda (n) | |\n| (if | |\n| (= n 0) | |\n| 1 | |\n| (* n | |\n| (fact | |\n| (- n 1))))))) | |\n| fact) | |\n| \"(int -> int)\") | |\n| (assert-type | |\n| '(letrec | |\n| ((map | |\n| (lambda (f) | |\n| (lambda (xs) | |\n| (if | |\n| (null? xs) | |\n| nil | |\n| (cons | |\n| (f (head xs)) | |\n| ((map f) | |\n| (tail xs)))))))) | |\n| map) | |\n| \"((a -> b) -> ([a] -> [b]))\") | |\n| (assert-type | |\n| '(begin | |\n| 1 | |\n| 2 | |\n| 3) | |\n| \"int\") | |\n| (assert-type | |\n| '(tuple 1 #t 3) | |\n| \"(int * bool * int)\") | |\n| ;; expected failures | |\n| ;; | |\n| ;; (infer-type | |\n| ;; '(+ #t 1)) | |\n| ;; | |\n| ;; cannot unify bool with int | |\n| ;; | |\n| ;; (infer-type | |\n| ;; '(if #t 1 #f)) | |\n| ;; | |\n| ;; cannot unify int with bool | |\n| ;; | |\n| ;; (infer-type | |\n| ;; '(lambda (x) | |\n| ;; (x x))) | |\n| ;; | |\n| ;; occurs-check failure | |\n| ;; | |\n| ;; (infer-type | |\n| ;; '(let ((f | |\n| ;; (lambda (x) | |\n| ;; (+ x 1)))) | |\n| ;; (f #t))) | |\n| ;; | |\n| ;; cant unify bool with int | |\n| (display | |\n| (infer-type | |\n| '(lambda (x) | |\n| x))) | |\n| (newline) | |\n| (display | |\n| (infer-type | |\n| '(lambda (f) | |\n| (lambda (g) | |\n| (lambda (x) | |\n| (f (g x)))))) | |\n| (newline) | |\n| (display | |\n| (infer-type | |\n| '(let ((id | |\n| (lambda (x) | |\n| x))) | |\n| (tuple | |\n| (id 42) | |\n| (id #t))))) | |\n| (newline) | |\n| (display | |\n| (infer-type | |\n| '(letrec | |\n| ((fact | |\n| (lambda (n) | |\n| (if | |\n| (= n 0) | |\n| 1 | |\n| (* n | |\n| (fact | |\n| (- n 1))))))) | |\n| fact)) | |\n| (newline) |", "url": "https://wpnews.pro/news/scheme-impl-of-hindley-milner-type-inference-based-on-milner-s-algorithm-w-and", "canonical_source": "https://gist.github.com/vamp1nn/698aa18dbb470e45c2a2ae334e14fbb9", "published_at": "2026-09-03 03:10:11+00:00", "updated_at": "2026-09-03 03:22:23.848490+00:00", "lang": "en", "topics": ["developer-tools"], "entities": ["Robin Milner", "Luis Damas", "Scheme"], "alternates": {"html": "https://wpnews.pro/news/scheme-impl-of-hindley-milner-type-inference-based-on-milner-s-algorithm-w-and", "markdown": "https://wpnews.pro/news/scheme-impl-of-hindley-milner-type-inference-based-on-milner-s-algorithm-w-and.md", "text": "https://wpnews.pro/news/scheme-impl-of-hindley-milner-type-inference-based-on-milner-s-algorithm-w-and.txt", "jsonld": "https://wpnews.pro/news/scheme-impl-of-hindley-milner-type-inference-based-on-milner-s-algorithm-w-and.jsonld"}}