├── .gitignore ├── share.rkt ├── README.md ├── uni-typed.rkt ├── interp-cps.rkt ├── stlc.rkt ├── interp-delimited.rkt ├── stlc+sub.rkt ├── stlc+sum+prod.rkt ├── linear.rkt ├── letpoly.rkt ├── systemf.rkt ├── stlc-omega.rkt ├── stlc-infer.rkt ├── systemf+ext.rkt └── systemf-omega.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | compiled 3 | -------------------------------------------------------------------------------- /share.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (for-syntax syntax/parse) 4 | rackunit) 5 | 6 | (provide type-error 7 | make-lookup 8 | check-values-equal? 9 | counter simple-counter) 10 | 11 | (define type-error 12 | (case-lambda 13 | [(msg) (error 'type-error "~a" msg)] 14 | [(e ty) (error 'type-error "~a should has type: ~a" e ty)])) 15 | 16 | (define (make-lookup error-hint isa? name-of val-of) 17 | (λ (name vals) 18 | (cond [(empty? vals) (error error-hint "free variable: ~a" name)] 19 | [(and (isa? (first vals)) 20 | (equal? name (name-of (first vals)))) 21 | (val-of (first vals))] 22 | [else ((make-lookup error-hint isa? name-of val-of) name (rest vals))]))) 23 | 24 | (define-syntax (check-values-equal? stx) 25 | (syntax-parse stx 26 | [(_ v1 v2) 27 | #'(call-with-values (λ () v1) 28 | (λ vlist1 (call-with-values (λ () v2) 29 | (λ vlist2 (check-true (equal? vlist1 vlist2))))))])) 30 | 31 | (define (simple-counter) 32 | (define count 0) 33 | (define (inner) 34 | (set! count (add1 count)) 35 | count) 36 | inner) 37 | 38 | (define (counter) 39 | (define count 0) 40 | (define (inner) 41 | (set! count (add1 count)) 42 | count) 43 | (values inner (λ () count))) 44 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## My PL Zoo 2 | 3 | > Inside every large language is a small language struggling to get out... 4 | > Tony Hoare 5 | 6 | Interpreters and type checkers of various toy programming languages written in Racket. 7 | 8 | Each file is a standalone and runnable implementation, including a parser for S-expression based syntax, a type checker if necessary, an interpreter and a set of test cases written in that language. 9 | 10 | * `uni-typed.rkt` Uni-typed lambda calculus with numbers and arithmetics 11 | 12 | * `interp-cps.rkt` An interpreter that supports `call/cc` operator 13 | 14 | * `interp-delimited.rkt` An interpreter that supports delimited control operators (`reset` and `shift`) 15 | 16 | * `stlc.rkt` Simply typed lambda calculus (STLC) 17 | 18 | * `stlc-infer.rkt` STLC with type inference 19 | 20 | * `stlc+sub.rkt` STLC + record + subtyping 21 | 22 | * `stlc+sum+prod.rkt` STLC + sum/product types 23 | 24 | * `stlc-omega.rkt` STLC + type operator 25 | 26 | * `stlc+intsec.rkt` STLC + intersection types #TODO# 27 | 28 | * `stlc+rec.rkt` STLC + sum/product tpye + recursive function + recursive types #TODO# 29 | 30 | * `systemf.rkt` System F 31 | 32 | * `systemf+ext.rkt` System F + existential types 33 | 34 | * `systemf-omega.rkt` System F-omega 35 | 36 | * `systemf+sub.rkt` System F + bounded quantifications and Subtyping #TODO# 37 | 38 | * `letpoly.rkt` STLC with type inference and let-polymorphism 39 | 40 | * `lf.rkt` First-order dependent types, i.e. λLF #TODO# 41 | 42 | * `lf+sum.rkt` λLF + sigma types #TODO# 43 | 44 | * `linear.rkt` Pure linear types 45 | 46 | * `stlc+linear.rkt` STLC with linear types #TODO# 47 | 48 | * `refinement.rkt` Refinement types #TODO# 49 | 50 | * `cpcf.rkt` Contract PCF with dependent contract #TODO# 51 | 52 | * `gradual.rkt` STLC with gradual types #TODO# 53 | 54 | -------------------------------------------------------------------------------- /uni-typed.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Uni-typed Lambda Calculus 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct IdE (id) #:transparent) 13 | (struct PlusE (l r) #:transparent) 14 | (struct MultE (l r) #:transparent) 15 | (struct AppE (fun arg) #:transparent) 16 | (struct LamE (arg body) #:transparent) 17 | (struct If0E (cnd thn els) #:transparent) 18 | 19 | ;; Values 20 | 21 | (struct NumV (n) #:transparent) 22 | (struct ClosureV (arg body env) #:transparent) 23 | 24 | ;; Environment 25 | 26 | (struct Binding (name val) #:transparent) 27 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 28 | (define ext-env cons) 29 | 30 | ;; Parser 31 | 32 | (define (parse s) 33 | (match s 34 | [(? number? x) (NumE x)] 35 | [(? symbol? x) (IdE x)] 36 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 37 | [`(* ,l ,r) (MultE (parse l) (parse r))] 38 | [`(λ (,var) ,body) (LamE var (parse body))] 39 | [`(let ([,var ,val]) ,body) 40 | (AppE (LamE var (parse body)) (parse val))] 41 | [`(if0 ,cnd ,thn ,els) 42 | (If0E (parse cnd) (parse thn) (parse els))] 43 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 44 | [else (error 'parse "invalid expression")])) 45 | 46 | ;; Interpreter 47 | 48 | (define (interp expr env) 49 | (match expr 50 | [(IdE x) (lookup x env)] 51 | [(NumE n) (NumV n)] 52 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 53 | (NumV-n (interp r env))))] 54 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 55 | (NumV-n (interp r env))))] 56 | [(LamE arg body) (ClosureV arg body env)] 57 | [(If0E cnd thn els) 58 | (match (interp cnd env) 59 | [(NumV 0) (interp thn env)] 60 | [(NumV _) (interp els env)] 61 | [else (error 'interp "not a number")])] 62 | [(AppE fun arg) 63 | (match (interp fun env) 64 | [(ClosureV n body env*) 65 | (interp body (ext-env (Binding n (interp arg env)) env*))] 66 | [else (error 'interp "not a function")])])) 67 | 68 | (define mt-env empty) 69 | (define mt-tenv empty) 70 | 71 | (define (run prog) 72 | (define prog* (parse prog)) 73 | (interp prog* mt-env)) 74 | 75 | ;; Tests 76 | 77 | (module+ test 78 | (check-equal? (run '1) (NumV 1)) 79 | (check-equal? (run '{let {[double {λ {x} {+ x x}}]} 80 | {double {double 3}}}) 81 | (NumV 12)) 82 | (check-equal? (run '{let {[five {if0 0 5 6}]} five}) 83 | (NumV 5)) 84 | ) 85 | -------------------------------------------------------------------------------- /interp-cps.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require "share.rkt") 5 | 6 | ;; Expressions 7 | 8 | (struct NumE (n) #:transparent) 9 | (struct IdE (id) #:transparent) 10 | (struct PlusE (l r) #:transparent) 11 | (struct MultE (l r) #:transparent) 12 | (struct AppE (fun arg) #:transparent) 13 | (struct LamE (arg body) #:transparent) 14 | (struct CallccE (k body) #:transparent) 15 | 16 | ;; Values 17 | 18 | (struct NumV (n) #:transparent) 19 | (struct ClosureV (arg body env) #:transparent) 20 | 21 | (struct Cont (body)) 22 | 23 | ;; Environment 24 | 25 | (struct Binding (name val) #:transparent) 26 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 27 | (define ext-env cons) 28 | 29 | ;; Parser 30 | 31 | (define (parse s) 32 | (match s 33 | [(? number? x) (NumE x)] 34 | [(? symbol? x) (IdE x)] 35 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 36 | [`(* ,l ,r) (MultE (parse l) (parse r))] 37 | [`(λ (,var) ,body) (LamE var (parse body))] 38 | [`(call/cc (λ (,k) ,body)) 39 | (CallccE k (parse body))] 40 | [`(let/cc ,k ,body) 41 | (CallccE k (parse body))] 42 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 43 | [else (error 'parse "invalid expression")])) 44 | 45 | ;; Interpreter 46 | 47 | (define (primop op l r) 48 | (match* (l r) 49 | [((NumV lv) (NumV rv)) 50 | (match op 51 | ['+ (NumV (+ lv rv))] 52 | ['* (NumV (* lv rv))])] 53 | [(_ _) (error 'primop "invalid operator")])) 54 | 55 | (define (interp-cps exp env k) 56 | (match exp 57 | [(IdE x) (k (lookup x env))] 58 | [(NumE n) (k (NumV n))] 59 | [(PlusE l r) 60 | (interp-cps l env 61 | (λ (lv) 62 | (interp-cps r env 63 | (λ (rv) 64 | (k (primop '+ lv rv))))))] 65 | [(MultE l r) 66 | (interp-cps l env 67 | (λ (lv) 68 | (interp-cps r env 69 | (λ (rv) 70 | (k (primop '* lv rv))))))] 71 | [(LamE arg body) 72 | (k (ClosureV arg body env))] 73 | [(CallccE x body) 74 | (interp-cps body (ext-env (Binding x (Cont k)) env) k)] 75 | [(AppE fun arg) 76 | (interp-cps fun env 77 | (λ (funv) 78 | (cond [(ClosureV? funv) 79 | (interp-cps arg env 80 | (λ (argv) 81 | (interp-cps (ClosureV-body funv) 82 | (ext-env (Binding (ClosureV-arg funv) argv) 83 | (ClosureV-env funv)) 84 | k)))] 85 | [(Cont? funv) (interp-cps arg env (Cont-body funv))] 86 | [else (error 'cps "not a function or continuation")])))])) 87 | 88 | (define mt-env empty) 89 | (define mt-k (lambda (v) v)) 90 | 91 | (define (run prog) 92 | (define prog* (parse prog)) 93 | (interp-cps prog* mt-env mt-k)) 94 | 95 | ;; Tests 96 | 97 | (check-equal? (run '{+ 1 2}) (NumV 3)) 98 | (check-equal? (run '{* 2 3}) (NumV 6)) 99 | (check-equal? (run '{{λ {x} {+ x x}} 3}) 100 | (NumV 6)) 101 | (check-equal? (run '{+ 1 {let/cc k1 102 | {+ 2 {+ 3 {let/cc k2 103 | {+ 4 {k1 5}}}}}}}) 104 | (NumV 6)) 105 | (check-equal? (run '{+ 1 {let/cc k1 106 | {+ 2 {+ 3 {let/cc k2 107 | {+ 4 {k2 5}}}}}}}) 108 | (NumV 11)) 109 | (check-equal? (run '{+ 1 {call/cc {λ {k1} 110 | {+ 2 {+ 3 {k1 4}}}}}}) 111 | (NumV 5)) 112 | -------------------------------------------------------------------------------- /stlc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Simply Typed Lamdba Calculus 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct AppE (fun arg) #:transparent) 17 | (struct LamE (arg arg-type body) #:transparent) 18 | (struct IfE (cnd thn els) #:transparent) 19 | 20 | ;; Types 21 | 22 | (struct NumT () #:transparent) 23 | (struct BoolT () #:transparent) 24 | (struct ArrowT (arg res) #:transparent) 25 | 26 | ;; Values 27 | 28 | (struct NumV (n) #:transparent) 29 | (struct BoolV (b) #:transparent) 30 | (struct ClosureV (arg body env) #:transparent) 31 | 32 | ;; Environment & Type Environment 33 | 34 | (struct Binding (name val) #:transparent) 35 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 36 | (define ext-env cons) 37 | 38 | (struct TypeBinding (name type) #:transparent) 39 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 40 | (define ext-tenv cons) 41 | 42 | ;; Parser 43 | 44 | (define (parse s) 45 | (match s 46 | [(? number? x) (NumE x)] 47 | ['true (BoolE #t)] 48 | ['false (BoolE #f)] 49 | [(? symbol? x) (IdE x)] 50 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 51 | [`(* ,l ,r) (MultE (parse l) (parse r))] 52 | [`(λ ([,var : ,ty]) ,body) 53 | (LamE var (parse-type ty) (parse body))] 54 | [`(let ([,var : ,ty ,val]) ,body) 55 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 56 | [`(if ,cnd ,thn ,els) 57 | (IfE (parse cnd) (parse thn) (parse els))] 58 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 59 | [else (error 'parse "invalid expression")])) 60 | 61 | (define (parse-type t) 62 | (match t 63 | ['num (NumT)] 64 | ['bool (BoolT)] 65 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 66 | [else (error 'parse-type "invalid type")])) 67 | 68 | ;; Type Checker 69 | 70 | (define (typecheck-nums l r tenv) 71 | (match* ((typecheck l tenv) (typecheck r tenv)) 72 | [((NumT) (NumT)) (NumT)] 73 | [(_ _) (type-error "not number")])) 74 | 75 | (define (typecheck exp tenv) 76 | (match exp 77 | [(NumE n) (NumT)] 78 | [(BoolE b) (BoolT)] 79 | [(PlusE l r) (typecheck-nums l r tenv)] 80 | [(MultE l r) (typecheck-nums l r tenv)] 81 | [(IdE n) (type-lookup n tenv)] 82 | [(IfE cnd thn els) 83 | (if (BoolT? (typecheck cnd tenv)) 84 | (let ([thn-type (typecheck thn tenv)] 85 | [els-type (typecheck els tenv)]) 86 | (if (equal? thn-type els-type) thn-type 87 | (type-error "types of branches not agree"))) 88 | (type-error "not a boolean"))] 89 | [(LamE arg arg-type body) 90 | (ArrowT arg-type (typecheck body (ext-tenv (TypeBinding arg arg-type) tenv)))] 91 | [(AppE fun arg) 92 | (match (typecheck fun tenv) 93 | [(ArrowT atype rtype) 94 | (if (equal? atype (typecheck arg tenv)) rtype 95 | (type-error "argument types not agree"))] 96 | [_ (type-error "not a function")])])) 97 | 98 | ;; Interpreter 99 | 100 | (define (interp expr env) 101 | (match expr 102 | [(IdE x) (lookup x env)] 103 | [(NumE n) (NumV n)] 104 | [(BoolE b) (BoolV b)] 105 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 106 | (NumV-n (interp r env))))] 107 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 108 | (NumV-n (interp r env))))] 109 | [(LamE arg at body) (ClosureV arg body env)] 110 | [(IfE cnd thn els) 111 | (match (interp cnd env) 112 | [(BoolV #t) (interp thn env)] 113 | [(BoolV #f) (interp els env)])] 114 | [(AppE fun arg) 115 | (match (interp fun env) 116 | [(ClosureV n body env*) 117 | (interp body (ext-env (Binding n (interp arg env)) env*))])])) 118 | 119 | (define mt-env empty) 120 | (define mt-tenv empty) 121 | 122 | (define (run prog) 123 | (define prog* (parse prog)) 124 | (typecheck prog* mt-tenv) 125 | (interp prog* mt-env)) 126 | 127 | ;; Tests 128 | 129 | (module+ test 130 | (check-equal? (run '1) (NumV 1)) 131 | (check-equal? (run '{λ {[x : num]} x}) 132 | (ClosureV 'x (IdE 'x) '())) 133 | (check-equal? (run '{{λ {[x : num]} {+ x x}} 3}) 134 | (NumV 6)) 135 | (check-equal? (run '{let {[double : {num -> num} 136 | {λ {[x : num]} {+ x x}}]} 137 | {double 3}}) 138 | (NumV 6)) 139 | (check-equal? (run '{{if true 140 | {λ {[x : num]} {+ x 1}} 141 | {λ {[x : num]} {+ x 2}}} 142 | 3}) 143 | (NumV 4)) 144 | ) 145 | -------------------------------------------------------------------------------- /interp-delimited.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require rackunit) 4 | (require "share.rkt") 5 | 6 | ;; Expressions 7 | 8 | (struct NumE (n) #:transparent) 9 | (struct IdE (id) #:transparent) 10 | (struct PlusE (l r) #:transparent) 11 | (struct MultE (l r) #:transparent) 12 | (struct AppE (fun arg) #:transparent) 13 | (struct LamE (arg body) #:transparent) 14 | (struct CallccE (k body) #:transparent) 15 | (struct ResetE (e) #:transparent) 16 | (struct ShiftE (k body) #:transparent) 17 | 18 | ;; Values 19 | 20 | (struct NumV (n) #:transparent) 21 | (struct ClosureV (arg body env) #:transparent) 22 | 23 | (struct Cont (body)) 24 | 25 | ;; Environment 26 | 27 | (struct Binding (name val) #:transparent) 28 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 29 | (define ext-env cons) 30 | 31 | ;; Parser 32 | 33 | (define (parse s) 34 | (match s 35 | [(? number? x) (NumE x)] 36 | [(? symbol? x) (IdE x)] 37 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 38 | [`(* ,l ,r) (MultE (parse l) (parse r))] 39 | [`(λ (,var) ,body) (LamE var (parse body))] 40 | [`(call/cc (λ (,k) ,body)) 41 | (CallccE k (parse body))] 42 | [`(let/cc ,k ,body) 43 | (CallccE k (parse body))] 44 | [`(reset ,e) (ResetE (parse e))] 45 | [`(shift ,k ,body) 46 | (ShiftE k (parse body))] 47 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 48 | [else (error 'parse "invalid expression")])) 49 | 50 | ;; Interpreter 51 | 52 | (define (primop op l r) 53 | (match* (l r) 54 | [((NumV lv) (NumV rv)) 55 | (match op 56 | ['+ (NumV (+ lv rv))] 57 | ['* (NumV (* lv rv))])] 58 | [(_ _) (error 'primop "invalid operator")])) 59 | 60 | (define (interpd exp env k r) 61 | (match exp 62 | [(IdE x) ((k r) (lookup x env))] 63 | [(NumE n) ((k r) (NumV n))] 64 | [(PlusE lhs rhs) 65 | (interpd lhs env 66 | (λ (r) 67 | (λ (lv) 68 | (interpd rhs env 69 | (λ (r) 70 | (λ (rv) 71 | ((k r) (primop '+ lv rv)))) 72 | r))) 73 | r)] 74 | [(MultE lhs rhs) 75 | (interpd lhs env 76 | (λ (r) 77 | (λ (lv) 78 | (interpd rhs env 79 | (λ (r) 80 | (λ (rv) 81 | ((k r) (primop '* lv rv)))) 82 | r))) 83 | r)] 84 | [(LamE arg body) 85 | ((k r) (ClosureV arg body env))] 86 | [(CallccE x e) 87 | (interpd e (ext-env (Binding x (Cont (λ (k1) 88 | (λ (r) 89 | (λ (v) 90 | ((k r) v)))))) ; discard k1, do k and escape 91 | env) 92 | k 93 | r)] 94 | [(ResetE e) 95 | (interpd e env (λ (r) r) (k r))] 96 | [(ShiftE x e) 97 | (interpd e (ext-env (Binding x (Cont (λ (k1) 98 | (λ (r) 99 | (λ (v) 100 | ((k (k1 r)) v)))))) ; do k and go back to k1 101 | env) 102 | (λ (r) r) 103 | r)] 104 | [(AppE fun arg) 105 | (interpd fun env 106 | (λ (r) 107 | (λ (funv) 108 | (cond [(ClosureV? funv) 109 | (interpd arg env 110 | (λ (r) 111 | (λ (argv) 112 | (interpd (ClosureV-body funv) 113 | (ext-env (Binding (ClosureV-arg funv) argv) 114 | (ClosureV-env funv)) 115 | k 116 | r))) 117 | r)] 118 | [(Cont? funv) (interpd arg env ((Cont-body funv) k) r)]))) ; feed with current continuation `k` 119 | r)])) 120 | 121 | 122 | (define mt-env empty) 123 | (define mt-k (λ (r) (λ (v) (r v)))) 124 | (define mt-r (λ (x) x)) 125 | 126 | (define (run prog) 127 | (define prog* (parse prog)) 128 | (interpd prog* mt-env mt-k mt-r)) 129 | 130 | ;; Tests 131 | 132 | (check-equal? (run '{+ 1 2}) (NumV 3)) 133 | (check-equal? (run '{* 2 3}) (NumV 6)) 134 | (check-equal? (run '{{λ {x} {+ x x}} 3}) 135 | (NumV 6)) 136 | (check-equal? (run '{+ 1 {let/cc k1 137 | {+ 2 {+ 3 {let/cc k2 138 | {+ 4 {k1 5}}}}}}}) 139 | (NumV 6)) 140 | (check-equal? (run '{+ 1 {let/cc k1 141 | {+ 2 {+ 3 {let/cc k2 142 | {+ 4 {k2 5}}}}}}}) 143 | (NumV 11)) 144 | (check-equal? (run '{+ 1 {call/cc {λ {k1} 145 | {+ 2 {+ 3 {k1 4}}}}}}) 146 | (NumV 5)) 147 | 148 | (check-equal? (run '{+ 5 {reset {+ 2 {shift k {+ 1 {k {k 3}}}}}}}) 149 | (NumV 13)) 150 | 151 | (check-equal? (run '{+ 5 {reset {+ 3 {shift c {+ {c 0} {c 1}}}}}}) 152 | (NumV 12)) 153 | 154 | (check-equal? (run '{+ 1 {reset {+ 2 {reset {+ 4 {shift k {shift k2 8}}}}}}}) 155 | (NumV 11)) 156 | #| 157 | {+ 1 {reset {+ 2 {reset {+ 4 {shift k {shift k2 {k {k2 8}}}}}}}}} 158 | 159 | {+ 1 {reset {+ 2 {reset {{λ {k} {shift k2 {k {k2 8}}}} 160 | {λ {v} {reset {+ 4 v}}}}}}}} 161 | 162 | {+ 1 {reset {+ 2 {reset {{λ {k} {shift k2 {k {k2 8}}}} 163 | {λ {v} {reset {+ 4 v}}}}}}}} 164 | 165 | {+ 1 {reset {+ 2 {reset {{λ {k2} {k2 8}} 166 | {λ {v2} 167 | {reset {{λ {k} {k v2}} 168 | {λ {v} {reset {+ 4 v}}}}}}}}}}} 169 | |# 170 | 171 | (check-equal? (run '{{λ {f} {+ 1 {reset {+ 2 {f 3}}}}} 172 | {λ {x} {shift k x}}}) 173 | (NumV 4)) 174 | 175 | (check-equal? (run '{reset {+ 1 {+ {shift a {a 1}} 176 | {shift b {b {b 1}}}}}}) 177 | (NumV 5)) 178 | 179 | (check-equal? (run '{+ 2 {+ 1 {call/cc {λ {k1} 180 | {+ 2 {+ 3 {k1 4}}}}}}}) 181 | (NumV 7)) 182 | 183 | (check-equal? (run '{+ 2 {reset {+ 1 {call/cc {λ {k1} 184 | {+ 2 {+ 3 {k1 4}}}}}}}}) 185 | (NumV 7)) 186 | 187 | (check-equal? (run '{+ 1 {let/cc k1 188 | {+ 2 {+ 3 {let/cc k2 189 | {+ 4 {k1 5}}}}}}}) 190 | (NumV 6)) 191 | 192 | (check-equal? (run '{+ 1 {let/cc k1 193 | {+ 2 {+ 3 {let/cc k2 194 | {+ 4 {k2 5}}}}}}}) 195 | (NumV 11)) 196 | -------------------------------------------------------------------------------- /stlc+sub.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Simply Typed Lamdba Calculus with Record and Subtyping 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct AppE (fun arg) #:transparent) 17 | (struct LamE (arg arg-type body) #:transparent) 18 | (struct IfE (cnd thn els) #:transparent) 19 | 20 | (struct RecordE (ns es) #:transparent) 21 | (struct GetE (rec n) #:transparent) 22 | (struct SetE (rec n val) #:transparent) 23 | 24 | ;; Types 25 | 26 | (struct NumT () #:transparent) 27 | (struct BoolT () #:transparent) 28 | (struct ArrowT (arg res) #:transparent) 29 | (struct RecordT (ns ts) #:transparent) 30 | 31 | ;; Values 32 | 33 | (struct NumV (n) #:transparent) 34 | (struct BoolV (b) #:transparent) 35 | (struct RecordV (ns vs) #:transparent) 36 | (struct ClosureV (arg body env) #:transparent) 37 | 38 | ;; Environment & Type Environment 39 | 40 | (struct Binding (name val) #:transparent) 41 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 42 | (define ext-env cons) 43 | 44 | (struct TypeBinding (name type) #:transparent) 45 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 46 | (define ext-tenv cons) 47 | 48 | ;; Parser 49 | 50 | (define (parse s) 51 | (match s 52 | [(? number? x) (NumE x)] 53 | ['true (BoolE #t)] 54 | ['false (BoolE #f)] 55 | [(? symbol? x) (IdE x)] 56 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 57 | [`(* ,l ,r) (MultE (parse l) (parse r))] 58 | [`(rec {,ns : ,vs} ...) 59 | (RecordE ns (map parse vs))] 60 | [`(get ,rec ,n) 61 | (GetE (parse rec) n)] 62 | [`(set ,rec ,n ,val) 63 | (SetE (parse rec) n (parse val))] 64 | [`(lambda ([,var : ,ty]) ,body) 65 | (LamE var (parse-type ty) (parse body))] 66 | [`(let ([,var : ,ty ,val]) ,body) 67 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 68 | [`(if ,cnd ,thn ,els) 69 | (IfE (parse cnd) (parse thn) (parse els))] 70 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 71 | [else (error 'parse "invalid expression")])) 72 | 73 | (define (parse-type t) 74 | (match t 75 | ['num (NumT)] 76 | ['bool (BoolT)] 77 | [`((,ns : ,ts) ...) (RecordT ns (map parse-type ts))] 78 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 79 | [else (error 'parse-type "invalid type")])) 80 | 81 | ;; Type Checker 82 | 83 | (define (typecheck-nums l r tenv) 84 | (match* ((typecheck l tenv) (typecheck r tenv)) 85 | [((NumT) (NumT)) (NumT)] 86 | [(_ _) (type-error "not number")])) 87 | 88 | (define (record-find n ns ts) 89 | (cond [(empty? ns) (error 'find "can not find")] 90 | [else (if (symbol=? n (first ns)) (first ts) 91 | (record-find n (rest ns) (rest ts)))])) 92 | 93 | ;; is t1 a subtype of t2? 94 | (define (subtype? t1 t2) 95 | (match* (t1 t2) 96 | [((NumT) (NumT)) #t] 97 | [((NumT) _) #f] 98 | [((BoolT) (BoolT)) #t] 99 | [((BoolT) _) #f] 100 | [((ArrowT l1 r1) (ArrowT l2 r2)) 101 | (and (subtype? l2 l1) ;contra-variant 102 | (subtype? r1 r2))] ;co-variant 103 | [((ArrowT _ _) _) #f] 104 | [((RecordT ns1 ts1) (RecordT ns2 ts2)) 105 | ; every field in ns2 must be in ns1 and types in 106 | ; ts1 should be a subtype of the one in ts2 107 | (andmap (λ (n) (and (member n ns1) 108 | (subtype? (record-find n ns1 ts1) 109 | (record-find n ns2 ts2)))) 110 | ns2)] 111 | [((RecordT _ _) _) #f] 112 | [(_ _) #f])) 113 | 114 | (define (typecheck exp tenv) 115 | (match exp 116 | [(NumE n) (NumT)] 117 | [(BoolE b) (BoolT)] 118 | [(PlusE l r) (typecheck-nums l r tenv)] 119 | [(MultE l r) (typecheck-nums l r tenv)] 120 | [(IdE n) (type-lookup n tenv)] 121 | [(IfE cnd thn els) 122 | (if (BoolT? (typecheck cnd tenv)) 123 | (let ([thn-type (typecheck thn tenv)] 124 | [els-type (typecheck els tenv)]) 125 | (if (equal? thn-type els-type) thn-type 126 | (type-error "types of branches not agree"))) 127 | (type-error "not a boolean"))] 128 | [(LamE arg arg-type body) 129 | (ArrowT arg-type (typecheck body (ext-tenv (TypeBinding arg arg-type) tenv)))] 130 | [(AppE fun arg) 131 | (match (typecheck fun tenv) 132 | [(ArrowT atype rtype) 133 | (if (subtype? (typecheck arg tenv) atype) rtype 134 | (type-error "argument types not agree"))] 135 | [_ (type-error "not a function")])] 136 | [(RecordE ns es) 137 | (RecordT ns (map (λ (e) (typecheck e tenv)) es))] 138 | [(GetE rec n) 139 | (match (typecheck rec tenv) 140 | [(RecordT ns ts) (record-find n ns ts)] 141 | [else (type-error "not a record")])] 142 | [(SetE rec n val) 143 | (define rec-type (typecheck rec tenv)) 144 | (match rec-type 145 | [(RecordT ns ts) 146 | (define field-type (record-find n ns ts)) 147 | (if (subtype? (typecheck val tenv) field-type) 148 | rec-type 149 | (type-error "should be subtype of field"))] 150 | [_ (type-error "not a record")])])) 151 | 152 | ;; Interpreter 153 | 154 | (define (interp expr env) 155 | (match expr 156 | [(IdE x) (lookup x env)] 157 | [(NumE n) (NumV n)] 158 | [(BoolE b) (BoolV b)] 159 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 160 | (NumV-n (interp r env))))] 161 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 162 | (NumV-n (interp r env))))] 163 | [(LamE arg at body) (ClosureV arg body env)] 164 | [(AppE fun arg) 165 | (match (interp fun env) 166 | [(ClosureV n body env*) 167 | (interp body (ext-env (Binding n (interp arg env)) env*))])] 168 | [(RecordE ns es) 169 | (RecordV ns (map (λ (e) (box (interp e env))) es))] 170 | [(GetE rec n) 171 | (define rec-v (interp rec env)) 172 | (unbox (record-find n (RecordV-ns rec-v) (RecordV-vs rec-v)))] 173 | [(SetE rec n v) 174 | (define rec-v (interp rec env)) 175 | (set-box! (record-find n (RecordV-ns rec-v) (RecordV-vs rec-v)) 176 | (interp v env)) 177 | rec-v] 178 | [(IfE cnd thn els) 179 | (match (interp cnd env) 180 | [(BoolV #t) (interp thn env)] 181 | [(BoolV #f) (interp els env)])])) 182 | 183 | (define mt-env empty) 184 | (define mt-tenv empty) 185 | 186 | (define (run prog) 187 | (define prog* (parse prog)) 188 | (typecheck prog* mt-tenv) 189 | (interp prog* mt-env)) 190 | 191 | ;; Tests 192 | 193 | (module+ test 194 | (check-equal? (parse-type '{{x : num} {y : num}}) 195 | (RecordT '(x y) (list (NumT) (NumT)))) 196 | (check-equal? (parse-type '{{x : {num -> num}} 197 | {y : {bool -> bool}}}) 198 | (RecordT '(x y) (list (ArrowT (NumT) (NumT)) 199 | (ArrowT (BoolT) (BoolT))))) 200 | 201 | (check-equal? (parse '{let {[r : {{x : num}} {rec {x : 3}}]} 202 | {get r x}}) 203 | (AppE 204 | (LamE 'r (RecordT '(x) (list (NumT))) (GetE (IdE 'r) 'x)) 205 | (RecordE '(x) (list (NumE 3))))) 206 | 207 | (check-equal? (typecheck (parse '{let {[r : {{x : num}} {rec {x : 3}}]} 208 | {get r x}}) mt-tenv) 209 | (NumT)) 210 | 211 | (check-true (subtype? (parse-type '{{x : num} {y : num}}) 212 | (parse-type '{{x : num}}))) 213 | 214 | (check-true (subtype? (parse-type '{{{x : num}} -> {{x : num} {y : num}}}) 215 | (parse-type '{{{x : num} {y : num}} -> {{x : num}}}))) 216 | 217 | (check-equal? (typecheck (parse '{{lambda {[r : {{x : num}}]} {+ {get r x} 1}} 218 | {rec {x : 3} {y : 4}}}) 219 | mt-tenv) 220 | (NumT)) 221 | 222 | (check-equal? (typecheck (parse '{{lambda {[r : {{x : num}}]} {+ {get r x} 1}} 223 | {rec {y : true} {x : 4}}}) 224 | mt-tenv) 225 | (NumT)) 226 | 227 | (check-equal? (interp (parse '{let {[r : {{x : num}} {rec {x : 3}}]} 228 | {get r x}}) mt-env) 229 | (NumV 3)) 230 | 231 | (check-equal? (interp (parse '{{lambda {[r : {{x : num}}]} {+ {get r x} 1}} 232 | {rec {x : 3} {y : 4}}}) 233 | mt-env) 234 | (NumV 4)) 235 | 236 | (check-equal? (interp (parse '{{lambda {[r1 : {{x : num}}]} 237 | {let {[r2 : {{x : num}} 238 | {rec {x : 3}}]} 239 | {set r2 x {+ {get r1 x} {get r2 x}}}}} 240 | {rec {x : 4}}}) 241 | mt-env) 242 | (RecordV '(x) (list (box (NumV 7))))) 243 | 244 | ) 245 | -------------------------------------------------------------------------------- /stlc+sum+prod.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Simply Typed Lamdba Calculus with Sum Types and Product Types 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct AppE (fun arg) #:transparent) 17 | (struct LamE (arg arg-type body) #:transparent) 18 | (struct IfE (cnd thn els) #:transparent) 19 | 20 | ; Product 21 | 22 | (struct ProdE (fst snd) #:transparent) 23 | (struct FstE (p) #:transparent) 24 | (struct SndE (p) #:transparent) 25 | 26 | ; Sum 27 | 28 | (struct InLeftE (ty e) #:transparent) 29 | (struct InRightE (ty e) #:transparent) 30 | (struct MatchE (s v1 e1 v2 e2) #:transparent) 31 | 32 | ;; Types 33 | 34 | (struct NumT () #:transparent) 35 | (struct BoolT () #:transparent) 36 | (struct ArrowT (arg/t res/t) #:transparent) 37 | (struct ProdT (fst/t snd/t) #:transparent) 38 | (struct SumT (l/t r/t) #:transparent) 39 | 40 | ;; Values 41 | 42 | (struct NumV (n) #:transparent) 43 | (struct BoolV (b) #:transparent) 44 | (struct ClosureV (arg body env) #:transparent) 45 | (struct ProdV (fst snd) #:transparent) 46 | (struct SumV (label val) #:transparent) 47 | 48 | ;; Environment & Type Environment 49 | 50 | (struct Binding (name val) #:transparent) 51 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 52 | (define ext-env cons) 53 | 54 | (struct TypeBinding (name type) #:transparent) 55 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 56 | (define ext-tenv cons) 57 | 58 | ;; Parser 59 | 60 | (define (parse s) 61 | (match s 62 | [(? number? x) (NumE x)] 63 | ['true (BoolE #t)] 64 | ['false (BoolE #f)] 65 | [(? symbol? x) (IdE x)] 66 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 67 | [`(* ,l ,r) (MultE (parse l) (parse r))] 68 | [`(fst ,e) (FstE (parse e))] 69 | [`(snd ,e) (SndE (parse e))] 70 | [`(,l × ,r) (ProdE (parse l) (parse r))] 71 | [`(in-left ,e : ,ty) (InLeftE (parse-type ty) (parse e))] 72 | [`(in-right ,e : ,ty) (InRightE (parse-type ty) (parse e))] 73 | [`(match ,e ((,v1) ,e1) ((,v2) ,e2)) 74 | (MatchE (parse e) v1 (parse e1) v2 (parse e2))] 75 | [`(λ ([,var : ,ty]) ,body) 76 | (LamE var (parse-type ty) (parse body))] 77 | [`(let ([,var : ,ty ,val]) ,body) 78 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 79 | [`(if ,cnd ,thn ,els) 80 | (IfE (parse cnd) (parse thn) (parse els))] 81 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 82 | [else (error 'parse "invalid expression")])) 83 | 84 | (define (parse-type t) 85 | (match t 86 | ['num (NumT)] 87 | ['bool (BoolT)] 88 | [`(sum ,t1 ,t2) (SumT (parse-type t1) (parse-type t2))] 89 | [`(,tyfst × ,tysnd) (ProdT (parse-type tyfst) (parse-type tysnd))] 90 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 91 | [else (error 'parse-type "invalid type")])) 92 | 93 | ;; Type Checker 94 | 95 | (define (typecheck-nums l r tenv) 96 | (match* ((typecheck l tenv) (typecheck r tenv)) 97 | [((NumT) (NumT)) (NumT)] 98 | [(_ _) (type-error "not number")])) 99 | 100 | (define (typecheck exp tenv) 101 | (match exp 102 | [(NumE n) (NumT)] 103 | [(BoolE b) (BoolT)] 104 | [(PlusE l r) (typecheck-nums l r tenv)] 105 | [(MultE l r) (typecheck-nums l r tenv)] 106 | [(IdE n) (type-lookup n tenv)] 107 | [(ProdE l r) (ProdT (typecheck l tenv) 108 | (typecheck r tenv))] 109 | [(FstE p) (ProdT-fst/t (typecheck p tenv))] 110 | [(SndE p) (ProdT-snd/t (typecheck p tenv))] 111 | [(InLeftE ty e) 112 | (define l/t (typecheck e tenv)) 113 | (if (equal? l/t (SumT-l/t ty)) ty 114 | (type-error "sum types not agree"))] 115 | [(InRightE ty e) 116 | (define r/t (typecheck e tenv)) 117 | (if (equal? r/t (SumT-r/t ty)) ty 118 | (type-error "sum types not agree"))] 119 | [(MatchE se v1 e1 v2 e2) 120 | (match (typecheck se tenv) 121 | [(SumT l/t r/t) 122 | (define e1/t (typecheck e1 (ext-tenv (TypeBinding v1 l/t) tenv))) 123 | (define e2/t (typecheck e2 (ext-tenv (TypeBinding v2 r/t) tenv))) 124 | (if (equal? e1/t e2/t) e1/t 125 | (type-error "types of branches not agree"))] 126 | [else (type-error "not a sum type")])] 127 | [(IfE cnd thn els) 128 | (if (BoolT? (typecheck cnd tenv)) 129 | (let ([thn-type (typecheck thn tenv)] 130 | [els-type (typecheck els tenv)]) 131 | (if (equal? thn-type els-type) thn-type 132 | (type-error "types of branches not agree"))) 133 | (error 'typecheck "not a boolean"))] 134 | [(LamE arg arg-type body) 135 | (ArrowT arg-type (typecheck body (ext-tenv (TypeBinding arg arg-type) tenv)))] 136 | [(AppE fun arg) 137 | (match (typecheck fun tenv) 138 | [(ArrowT atype rtype) 139 | (if (equal? atype (typecheck arg tenv)) rtype 140 | (type-error "argument types not agree"))] 141 | [_ (type-error "not a function")])])) 142 | 143 | ;; Interpreter 144 | 145 | (define (interp expr env) 146 | (match expr 147 | [(IdE x) (lookup x env)] 148 | [(NumE n) (NumV n)] 149 | [(BoolE b) (BoolV b)] 150 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 151 | (NumV-n (interp r env))))] 152 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 153 | (NumV-n (interp r env))))] 154 | [(ProdE l r) (ProdV (interp l env) 155 | (interp r env))] 156 | [(FstE p) (ProdV-fst (interp p env))] 157 | [(SndE p) (ProdV-snd (interp p env))] 158 | [(InLeftE ty e) (SumV 'left (interp e env))] 159 | [(InRightE ty e) (SumV 'right (interp e env))] 160 | [(MatchE e v1 e1 v2 e2) 161 | (match (interp e env) 162 | [(SumV 'left val) (interp e1 (ext-env (Binding v1 val) env))] 163 | [(SumV 'right val) (interp e2 (ext-env (Binding v2 val) env))])] 164 | [(LamE arg at body) (ClosureV arg body env)] 165 | [(IfE cnd thn els) 166 | (match (interp cnd env) 167 | [(BoolV #t) (interp thn env)] 168 | [(BoolV #f) (interp els env)])] 169 | [(AppE fun arg) 170 | (match (interp fun env) 171 | [(ClosureV n body env*) 172 | (interp body (ext-env (Binding n (interp arg env)) env*))])])) 173 | 174 | (define mt-env empty) 175 | (define mt-tenv empty) 176 | 177 | (define (run prog) 178 | (define prog* (parse prog)) 179 | (typecheck prog* mt-tenv) 180 | (interp prog* mt-env)) 181 | 182 | ;; Tests 183 | 184 | (module+ test 185 | (check-equal? (parse '{3 × 4}) 186 | (ProdE (NumE 3) (NumE 4))) 187 | (check-equal? (parse '{λ {[x : {num × num}]} {fst x}}) 188 | (LamE 'x (ProdT (NumT) (NumT)) (FstE (IdE 'x)))) 189 | (check-equal? (parse '{in-left 3 : {sum num num}}) 190 | (InLeftE (SumT (NumT) (NumT)) (NumE 3))) 191 | (check-equal? (parse '{in-right 4 : {sum bool num}}) 192 | (InRightE (SumT (BoolT) (NumT)) (NumE 4))) 193 | (check-equal? (parse '{match {in-right 4 : {sum bool num}} 194 | {{l} {if l 3 4}} 195 | {{r} {+ r r}}}) 196 | (MatchE 197 | (InRightE (SumT (BoolT) (NumT)) (NumE 4)) 198 | 'l 199 | (IfE (IdE 'l) (NumE 3) (NumE 4)) 200 | 'r 201 | (PlusE (IdE 'r) (IdE 'r)))) 202 | 203 | (check-equal? (typecheck (parse '{match {in-right 4 : {sum bool num}} 204 | {{l} {if l 3 4}} 205 | {{r} {+ r r}}}) empty) 206 | (NumT)) 207 | 208 | (check-equal? (typecheck (parse '{match {in-left {in-left 3 : {sum num bool}} : {sum {sum num bool} bool}} 209 | {{l} {match l 210 | {{l1} {+ l1 3}} 211 | {{l2} {if l2 1 2}}}} 212 | {{r} {if r 1 2}}}) empty) 213 | (NumT)) 214 | 215 | (check-equal? (run '1) (NumV 1)) 216 | (check-equal? (run '{λ {[x : num]} x}) 217 | (ClosureV 'x (IdE 'x) '())) 218 | (check-equal? (run '{{λ {[x : num]} {+ x x}} 3}) 219 | (NumV 6)) 220 | (check-equal? (run '{let {[double : {num -> num} 221 | {λ {[x : num]} {+ x x}}]} 222 | {double 3}}) 223 | (NumV 6)) 224 | (check-equal? (run '{{if true 225 | {λ {[x : num]} {+ x 1}} 226 | {λ {[x : num]} {+ x 2}}} 227 | 3}) 228 | (NumV 4)) 229 | (check-equal? (run '{{λ {[p : {num × bool}]} 230 | {if {snd p} {fst p} {* 2 {fst p}}}} 231 | {3 × true}}) 232 | (NumV 3)) 233 | (check-equal? (run '{{λ {[p : {num × bool}]} 234 | {if {snd p} {fst p} {* 2 {fst p}}}} 235 | {3 × false}}) 236 | (NumV 6)) 237 | 238 | (check-equal? (run '{match {in-left {in-left 3 : {sum num bool}} : {sum {sum num bool} bool}} 239 | {{l} {match l 240 | {{l1} {+ l1 3}} 241 | {{l2} {if l2 1 2}}}} 242 | {{r} {if r 1 2}}}) 243 | (NumV 6)) 244 | ) 245 | -------------------------------------------------------------------------------- /linear.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Pure Linear Types 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Linear Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | 13 | (struct IdLE (x) #:transparent) 14 | (struct PlusLE (l r) #:transparent) 15 | (struct UnitLE () #:transparent) 16 | (struct LetUnitLE (e1 e2) #:transparent) 17 | (struct ProdLE (fst snd) #:transparent) 18 | (struct LetProdLE (x y e1 e2) #:transparent) 19 | (struct LamLE (arg arg/lt body) #:transparent) 20 | (struct AppLE (e1 e2) #:transparent) 21 | 22 | ;; Linear Types 23 | 24 | (struct NumT () #:transparent) 25 | 26 | (struct UnitLT () #:transparent) 27 | (struct ProdLT (fst/lt snd/lt) #:transparent) 28 | (struct ArrowLT (arg/lt res/lt) #:transparent) 29 | 30 | ;; Values 31 | 32 | (struct NumV (n) #:transparent) 33 | (struct ProdV (fst snd) #:transparent) 34 | (struct UnitV () #:transparent) 35 | (struct ClosureV (arg body env) #:transparent) 36 | 37 | ;; Environment & Type Environment 38 | 39 | (struct Binding (name val) #:transparent) 40 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 41 | (define ext-env cons) 42 | 43 | (struct TypeBinding (name type) #:transparent) 44 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 45 | (define ext-tenv cons) 46 | 47 | ;; Parser 48 | 49 | (define (parse s) 50 | (match s 51 | [(? number? x) (NumE x)] 52 | [(? symbol? x) (IdLE x)] 53 | ['() (UnitLE)] 54 | [`(+ ,l ,r) (PlusLE (parse l) (parse r))] 55 | [`(let ([() ,mt]) ,body) 56 | (LetUnitLE (parse mt) (parse body))] 57 | [`(let ([(,x ,y) ,e1]) ,body) 58 | (LetProdLE x y (parse e1) (parse body))] 59 | [`(λ ([,var : ,ty]) ,body) 60 | (LamLE var (parse-type ty) (parse body))] 61 | [`(,e1 ⊗ ,e2) (ProdLE (parse e1) (parse e2))] 62 | [`(,fun ,arg) (AppLE (parse fun) (parse arg))])) 63 | 64 | (define (parse-type t) 65 | (match t 66 | [`num (NumT)] 67 | [`unit (UnitLT)] 68 | [`(,t1 ⊗ ,t2) (ProdLT (parse-type t1) (parse-type t2))] 69 | [`(,t1 → ,t2) (ArrowLT (parse-type t1) (parse-type t2))])) 70 | 71 | ;; Type Checker 72 | 73 | (define (free-vars e) 74 | (match e 75 | [(NumE n) (set)] 76 | [(UnitLE) (set)] 77 | [(IdLE x) (set x)] 78 | [(PlusLE l r) 79 | (set-union (free-vars l) (free-vars r))] 80 | [(ProdLE e1 e2) 81 | (set-union (free-vars e1) (free-vars e2))] 82 | [(LetUnitLE e1 e2) (free-vars e2)] 83 | [(LetProdLE x y e1 e2) 84 | (set-union (free-vars e1) 85 | (set-subtract (free-vars e2) 86 | (set x y)))] 87 | [(LamLE arg arg/t body) 88 | (set-subtract (free-vars body) (set arg))] 89 | [(AppLE e1 e2) 90 | (set-union (free-vars e1) (free-vars e2))])) 91 | 92 | (define (partition-by Δ e1 e2) 93 | (define free-vars-e1 (set->list (free-vars e1))) 94 | (define free-vars-e2 (set->list (free-vars e2))) 95 | (if (empty? free-vars-e2) 96 | ;; TODO: verify Δ1 Δ2 97 | (partition (λ (b) (member (TypeBinding-name b) free-vars-e1)) Δ) 98 | (let-values ([(Δ2 Δ1) 99 | (partition (λ (b) (member (TypeBinding-name b) free-vars-e2)) Δ)]) 100 | (values Δ1 Δ2)))) 101 | 102 | (define (type-error-non-linear Δ) 103 | (type-error (format "not used: ~a" (map TypeBinding-name Δ)))) 104 | 105 | (define (typecheck e Δ) 106 | (match e 107 | [(NumE n) (if (empty? Δ) 108 | (NumT) 109 | (type-error-non-linear Δ))] 110 | [(UnitLE) (if (empty? Δ) 111 | (UnitLT) 112 | (type-error-non-linear Δ))] 113 | [(IdLE x) (if (eq? 1 (length Δ)) 114 | (type-lookup x Δ) 115 | (type-error-non-linear Δ))] 116 | [(PlusLE l r) 117 | (define-values (Δ1 Δ2) (partition-by Δ l r)) 118 | (match* ((typecheck l Δ1) (typecheck r Δ2)) 119 | [((NumT) (NumT)) (NumT)] 120 | [(_ _) (type-error "not a num")])] 121 | [(ProdLE l r) 122 | (define-values (Δ1 Δ2) (partition-by Δ l r)) 123 | (ProdLT (typecheck l Δ1) (typecheck r Δ2))] 124 | [(LetUnitLE u body) 125 | (define-values (Δ1 Δ2) (partition-by Δ u body)) 126 | (match (typecheck u Δ1) 127 | [(UnitLT) (typecheck body Δ2)] 128 | [else (type-error "not a unit type")])] 129 | [(LetProdLE x y p body) 130 | (define-values (Δ1 Δ2) (partition-by Δ p body)) 131 | (match (typecheck p Δ1) 132 | [(ProdLT f/t s/t) 133 | (typecheck body (ext-tenv (TypeBinding x f/t) 134 | (ext-tenv (TypeBinding y s/t) Δ2)))] 135 | [else (type-error "not a product type")])] 136 | [(LamLE arg arg/t body) 137 | (ArrowLT arg/t (typecheck body (ext-tenv (TypeBinding arg arg/t) Δ)))] 138 | [(AppLE fun arg) 139 | (define-values (Δ1 Δ2) (partition-by Δ fun arg)) 140 | (match (typecheck fun Δ1) 141 | [(ArrowLT a/t r/t) 142 | (if (equal? a/t (typecheck arg Δ2)) r/t 143 | (type-error "argument types not agree"))] 144 | [_ (type-error "not a function")])])) 145 | 146 | ;; Interpreter 147 | 148 | (define (interp expr env) 149 | (match expr 150 | [(NumE n) (NumV n)] 151 | [(IdLE x) (lookup x env)] 152 | [(UnitLE) (UnitV)] 153 | [(PlusLE l r) (NumV (+ (NumV-n (interp l env)) 154 | (NumV-n (interp r env))))] 155 | [(ProdLE l r) (ProdV (interp l env) (interp r env))] 156 | [(LamLE arg t body) (ClosureV arg body env)] 157 | [(LetUnitLE u body) (interp body env)] 158 | [(LetProdLE x y p body) 159 | (define pv (interp p env)) 160 | (interp body (ext-env (Binding x (ProdV-fst pv)) 161 | (ext-env (Binding y (ProdV-snd pv)) env)))] 162 | [(AppLE fun arg) 163 | (match (interp fun env) 164 | [(ClosureV n body env*) 165 | (interp body (ext-env (Binding n (interp arg env)) env*))])])) 166 | 167 | (define mt-env empty) 168 | (define mt-tenv empty) 169 | 170 | (define (run prog) 171 | (define prog* (parse prog)) 172 | (typecheck prog* mt-tenv) 173 | (interp prog* mt-env)) 174 | 175 | ;; Test 176 | 177 | (module+ test 178 | (check-equal? (parse '{{λ {[x : {num ⊗ num}]} 179 | {let {[(a b) x]} 180 | {+ a b}}} 181 | {3 ⊗ 4}}) 182 | (AppLE 183 | (LamLE 184 | 'x 185 | (ProdLT (NumT) (NumT)) 186 | (LetProdLE 'a 'b (IdLE 'x) (PlusLE (IdLE 'a) (IdLE 'b)))) 187 | (ProdLE (NumE 3) (NumE 4)))) 188 | 189 | (check-equal? (parse '{{λ {[x : unit]} 190 | {let {[() x]} 191 | 4}} 192 | {}}) 193 | (AppLE (LamLE 'x (UnitLT) (LetUnitLE (IdLE 'x) (NumE 4))) 194 | (UnitLE))) 195 | 196 | (check-equal? (free-vars (parse '{{λ {[x : {num ⊗ num}]} 197 | {let {[(a b) x]} 198 | {+ a b}}} 199 | {3 ⊗ 4}})) 200 | (set)) 201 | 202 | (check-equal? (free-vars (parse '{{λ {[x : {num ⊗ num}]} 203 | {let {[(a b) x]} 204 | {+ d y}}} 205 | {3 ⊗ 4}})) 206 | (set 'y 'd)) 207 | 208 | (check-equal? (typecheck (parse '{+ 1 2}) empty) 209 | (NumT)) 210 | 211 | (check-equal? (typecheck (parse '{λ {[x : num]} 212 | {λ {[y : num]} 213 | {+ x y}}}) empty) 214 | (ArrowLT (NumT) (ArrowLT (NumT) (NumT)))) 215 | 216 | (check-equal? (typecheck (parse '{λ {[x : {num ⊗ num}]} 217 | {let {[(a b) x]} 218 | {+ a b}}}) 219 | empty) 220 | (ArrowLT (ProdLT (NumT) (NumT)) (NumT))) 221 | 222 | (check-equal? (typecheck (parse '{{λ {[x : {num ⊗ num}]} 223 | {let {[(a b) x]} 224 | {+ a b}}} 225 | {3 ⊗ 4}}) empty) 226 | (NumT)) 227 | 228 | (check-equal? (typecheck (parse '{{λ {[u : unit]} 229 | {let {[() u]} 230 | 0}} 231 | ()}) 232 | empty) 233 | (NumT)) 234 | 235 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {[u : unit]} 236 | {let {[() u]} 237 | u}} 238 | ()}) 239 | empty))) 240 | 241 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {[x : {num ⊗ num}]} 242 | {let {[(a b) x]} 243 | {+ a a}}} 244 | {3 ⊗ 4}}) 245 | empty))) 246 | 247 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {[x : {num ⊗ num}]} 248 | {let {[(a b) x]} 249 | {+ 3 4}}} 250 | {3 ⊗ 4}}) 251 | empty))) 252 | 253 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {[x : {num ⊗ num}]} 254 | {let {[(a b) x]} 255 | {+ a 3}}} 256 | {3 ⊗ 4}}) 257 | empty))) 258 | 259 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {[x : {num ⊗ num}]} 260 | {let {[(a b) x]} 261 | {+ 3 a}}} 262 | {3 ⊗ 4}}) 263 | empty))) 264 | ) 265 | -------------------------------------------------------------------------------- /letpoly.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; An Implementation of Let-polymorphism with Type Inference 4 | 5 | (require rackunit) 6 | (require racket/set) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct LamE (arg body) #:transparent) 17 | (struct AppE (fun arg) #:transparent) 18 | (struct LetE (x e body) #:transparent) 19 | 20 | ;; Types 21 | 22 | (struct NumT () #:transparent) 23 | (struct BoolT () #:transparent) 24 | (struct VarT (n) #:transparent) 25 | (struct ArrowT (arg result) #:transparent) 26 | (struct ForallT (ns tybody) #:transparent) 27 | 28 | ;; Values 29 | 30 | (struct NumV (n) #:transparent) 31 | (struct BoolV (b) #:transparent) 32 | (struct PolyV (body env) #:transparent) 33 | (struct ClosureV (arg body env) #:transparent) 34 | 35 | ;; Environment & Type Environment 36 | 37 | (struct Binding (name val) #:transparent) 38 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 39 | (define ext-env cons) 40 | 41 | (struct TypeBinding (name type) #:transparent) 42 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 43 | (define ext-tenv cons) 44 | 45 | ;; Parser 46 | 47 | (define (parse s) 48 | (match s 49 | [(? number? x) (NumE x)] 50 | ['true (BoolE #t)] 51 | ['false (BoolE #f)] 52 | [(? symbol? x) (IdE x)] 53 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 54 | [`(* ,l ,r) (MultE (parse l) (parse r))] 55 | [`(let ([,var ,val]) ,body) 56 | (LetE var (parse val) (parse body))] 57 | [`(λ (,var) ,body) 58 | (LamE var (parse body))] 59 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 60 | [else (error 'parse "invalid expression")])) 61 | 62 | ;; Fresh Number Generator 63 | 64 | (define-values (fresh-n current-n) (counter)) 65 | 66 | (define (refresh!) 67 | (define-values (fresh-n^ current-n^) (counter)) 68 | (set! fresh-n fresh-n^) 69 | (set! current-n current-n^)) 70 | 71 | ;; Type Inference 72 | 73 | (struct Eq (fst snd) #:transparent) 74 | 75 | (define (free-type-var? n ty) 76 | (match ty 77 | [(NumT) #f] 78 | [(BoolT) #f] 79 | [(ArrowT a r) (or (free-type-var? n a) 80 | (free-type-var? n r))] 81 | [(VarT n^) (equal? n^ n)] 82 | [(ForallT n^ body) 83 | (if (equal? n n^) #f (free-type-var? n body))])) 84 | 85 | (define (generalize ty vars [gen-vars '{}]) 86 | (if (eq? vars 0) 87 | (if (empty? gen-vars) ty (ForallT gen-vars ty)) 88 | (if (free-type-var? vars ty) 89 | (generalize ty (- vars 1) (cons vars gen-vars)) 90 | (generalize ty (- vars 1) gen-vars)))) 91 | 92 | (define (instantiate ty ns) 93 | (cond [(empty? ns) ty] 94 | [else (instantiate (type-subst ty (VarT (car ns)) (VarT (fresh-n))) 95 | (rest ns))])) 96 | 97 | (define (type-subst in src dst) 98 | (match in 99 | [(NumT) in] 100 | [(BoolT) in] 101 | [(VarT x) (if (equal? src in) dst in)] 102 | [(ArrowT t1 t2) (ArrowT (type-subst t1 src dst) 103 | (type-subst t2 src dst))] 104 | [(ForallT n ty) 105 | (cond [(equal? src n) (ForallT n ty)] 106 | [(free-type-var? n dst) 107 | (define new-n (fresh-n)) 108 | (define new-ty (type-subst n (VarT new-n) ty)) 109 | (type-subst (ForallT new-n new-ty) src dst)] 110 | [else (ForallT n (type-subst ty src dst))])])) 111 | 112 | (define (unify/subst eqs src dst) 113 | (cond [(empty? eqs) eqs] 114 | [else (define eq (first eqs)) 115 | (define eqfst (Eq-fst eq)) 116 | (define eqsnd (Eq-snd eq)) 117 | (cons (Eq (type-subst eqfst src dst) 118 | (type-subst eqsnd src dst)) 119 | (unify/subst (rest eqs) src dst))])) 120 | 121 | (define (occurs? t in) 122 | (match in 123 | [(NumT) #f] 124 | [(BoolT) #f] 125 | [(VarT x) (equal? t in)] 126 | [(ArrowT at rt) (or (occurs? t at) (occurs? t rt))] 127 | [(ForallT n ty) 128 | (match t 129 | [(VarT n^) (if (eq? n n^) #f 130 | (occurs? t ty))] 131 | [_ (error 'occurs? "not a VarT")])])) 132 | 133 | (define not-occurs? (compose not occurs?)) 134 | 135 | (define (unify-error t1 t2) 136 | (error 'type-error "can not unify: ~a and ~a" t1 t2)) 137 | 138 | (define (unify/helper substs result) 139 | (match substs 140 | ['() result] 141 | [(list (Eq fst snd) rest ...) 142 | (match* (fst snd) 143 | [((VarT x) t) 144 | (if (not-occurs? fst snd) 145 | (unify/helper (unify/subst rest fst snd) (cons (Eq fst snd) result)) 146 | (unify-error fst snd))] 147 | [(t (VarT x)) 148 | (if (not-occurs? snd fst) 149 | (unify/helper (unify/subst rest snd fst) (cons (Eq snd fst) result)) 150 | (unify-error snd fst))] 151 | [((ArrowT t1 t2) (ArrowT t3 t4)) 152 | (unify/helper `(,(Eq t1 t3) ,(Eq t2 t4) ,@rest) result)] 153 | [(x x) (unify/helper rest result)] 154 | [(_ _) (unify-error fst snd)])])) 155 | 156 | (define (unify substs) (unify/helper (set->list substs) (list))) 157 | 158 | (define (type-infer exp tenv const) 159 | (match exp 160 | [(NumE n) (values (NumT) const)] 161 | [(BoolE b) (values (BoolT) const)] 162 | [(PlusE l r) 163 | (define-values (lty lconst) (type-infer l tenv (set))) 164 | (define-values (rty rconst) (type-infer r tenv (set))) 165 | (values (NumT) 166 | (set-add (set-add (set-union lconst rconst) (Eq lty (NumT))) (Eq rty (NumT))))] 167 | [(MultE l r) 168 | (define-values (lty lconst) (type-infer l tenv (set))) 169 | (define-values (rty rconst) (type-infer r tenv (set))) 170 | (values (NumT) 171 | (set-add (set-add (set-union lconst rconst) (Eq lty (NumT))) (Eq rty (NumT))))] 172 | [(IdE x) 173 | (values (type-lookup x tenv) const)] 174 | [(LamE arg body) 175 | (define new-tvar (VarT (fresh-n))) 176 | (define-values (bty bconst) 177 | (type-infer body (ext-tenv (TypeBinding arg new-tvar) tenv) const)) 178 | (values (ArrowT new-tvar bty) bconst)] 179 | [(LetE x e body) 180 | (define-values (ety econst) (type-infer e tenv (set))) 181 | (define new-var (VarT (fresh-n))) 182 | (define new-ety (generalize (reify (unify (set-add econst (Eq new-var ety))) new-var) 183 | (current-n))) 184 | (define-values (bdty bdconst) (type-infer body (ext-tenv (TypeBinding x new-ety) tenv) (set))) 185 | (values bdty (set-union econst bdconst))] 186 | [(AppE fun arg) 187 | (define-values (funty funconst) (type-infer fun tenv (set))) 188 | (define new-funty (match funty 189 | [(ForallT ns ty) (instantiate ty ns)] 190 | [_ funty])) 191 | (define-values (argty argconst) (type-infer arg tenv (set))) 192 | (define new-tvar (VarT (fresh-n))) 193 | (values new-tvar (set-add (set-union funconst argconst) (Eq new-funty (ArrowT argty new-tvar))))])) 194 | 195 | (define (reify substs ty) 196 | (define (lookup/default x sts) 197 | (match sts 198 | ['() x] 199 | [(list (Eq fst snd) rest ...) 200 | (if (equal? fst x) 201 | (lookup/default snd substs) 202 | (lookup/default x rest))])) 203 | 204 | (match ty 205 | [(NumT) (NumT)] 206 | [(BoolT) (BoolT)] 207 | [(VarT x) 208 | (define ans (lookup/default ty substs)) 209 | (if (ArrowT? ans) (reify substs ans) ans)] 210 | [(ArrowT t1 t2) 211 | (ArrowT (reify substs t1) (reify substs t2))] 212 | [(ForallT ns ty) 213 | (reify substs ty)])) 214 | 215 | (define (typecheck exp tenv) 216 | (refresh!) 217 | (define-values (ty constraints) (type-infer exp tenv (set))) 218 | (generalize (reify (unify constraints) ty) (current-n))) 219 | 220 | ;; Interpreter 221 | 222 | (define (interp expr env) 223 | (match expr 224 | [(IdE x) (lookup x env)] 225 | [(NumE n) (NumV n)] 226 | [(BoolE b) (BoolV b)] 227 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) (NumV-n (interp r env))))] 228 | [(MultE l r) (NumV (* (NumV-n (interp l env)) (NumV-n (interp r env))))] 229 | [(LamE arg body) (ClosureV arg body env)] 230 | [(AppE fun arg) 231 | (match (interp fun env) 232 | [(ClosureV n body env*) (interp body (ext-env (Binding n (interp arg env)) env*))])] 233 | [(LetE x e body) 234 | (interp body (ext-env (Binding x (interp e env)) env))])) 235 | 236 | (define mt-env empty) 237 | (define mt-tenv empty) 238 | 239 | (define (run prog) 240 | (define prog* (parse prog)) 241 | (typecheck prog* mt-tenv) 242 | (interp prog* mt-env)) 243 | 244 | ;; Tests 245 | 246 | (module+ test 247 | (check-equal? (generalize (ArrowT (VarT 1) (VarT 1)) 1 (list)) 248 | (ForallT (list 1) (ArrowT (VarT 1) (VarT 1)))) 249 | 250 | (check-equal? (typecheck (parse '{let {[id {λ {x} x}]} 251 | {{id {id {λ {y} y}}} 252 | {id 0}}}) 253 | empty) 254 | (NumT)) 255 | 256 | (check-equal? (typecheck (parse '{let {[plus {λ {x} {λ {y} {+ x y}}}]} 257 | {{plus 3} 4}}) 258 | empty) 259 | (NumT)) 260 | 261 | (check-equal? (typecheck (parse '{let {[id {λ {x} x}]} 262 | id}) 263 | empty) 264 | (ForallT '(1) (ArrowT (VarT 1) (VarT 1)))) 265 | 266 | (define S '{λ {x} {λ {y} {λ {z} {{x z} {y z}}}}}) 267 | (check-equal? (typecheck (parse S) mt-tenv) 268 | (ForallT '(3 5 6) 269 | (ArrowT (ArrowT (VarT 3) (ArrowT (VarT 5) (VarT 6))) 270 | (ArrowT (ArrowT (VarT 3) (VarT 5)) 271 | (ArrowT (VarT 3) (VarT 6)))))) 272 | 273 | (define K '{λ {x} {λ {y} x}}) 274 | (check-equal? (typecheck (parse K) mt-tenv) 275 | (ForallT '(1 2) (ArrowT (VarT 1) (ArrowT (VarT 2) (VarT 1))))) 276 | 277 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {id} {{id id} 3}} {λ {x} x}}) mt-tenv))) 278 | ) -------------------------------------------------------------------------------- /systemf.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Implementation of System F 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct LamE (arg arg-type body) #:transparent) 17 | (struct AppE (fun arg) #:transparent) 18 | (struct TyLamE (arg body) #:transparent) 19 | (struct TyAppE (tyfun tyarg) #:transparent) 20 | 21 | ;; Types 22 | 23 | (struct NumT () #:transparent) 24 | (struct BoolT () #:transparent) 25 | (struct VarT (name) #:transparent) 26 | (struct ArrowT (arg result) #:transparent) 27 | (struct ForallT (name tybody) #:transparent) 28 | 29 | ;; Values 30 | 31 | (struct NumV (n) #:transparent) 32 | (struct BoolV (b) #:transparent) 33 | (struct PolyV (body env) #:transparent) 34 | (struct ClosureV (arg body env) #:transparent) 35 | 36 | 37 | ;; Environment & Type Environment 38 | 39 | (struct Binding (name val) #:transparent) 40 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 41 | (define ext-env cons) 42 | 43 | (struct TypeVar (id) #:transparent) 44 | (struct TypeBinding (name type) #:transparent) 45 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 46 | (define type-var-lookup (make-lookup 'type-var-lookup TypeVar? TypeVar-id TypeVar-id)) 47 | (define ext-tenv cons) 48 | 49 | ;; Parser 50 | 51 | (define (parse s) 52 | (match s 53 | [(? number? x) (NumE x)] 54 | ['true (BoolE #t)] 55 | ['false (BoolE #f)] 56 | [(? symbol? x) (IdE x)] 57 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 58 | [`(* ,l ,r) (MultE (parse l) (parse r))] 59 | [`(let ([,var : ,ty ,val]) ,body) 60 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 61 | [`(λ ([,var : ,ty]) ,body) 62 | (LamE var (parse-type ty) (parse body))] 63 | [`(Λ [,tvar] ,body) (TyLamE tvar (parse body))] 64 | [`(@ ,tyfun ,tyarg) (TyAppE (parse tyfun) (parse-type tyarg))] 65 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 66 | [else (error 'parse "invalid expression")])) 67 | 68 | (define (parse-type t) 69 | (match t 70 | ['num (NumT)] 71 | ['bool (BoolT)] 72 | [(? symbol? tvar) (VarT tvar)] 73 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 74 | [`(∀ [,tvar] ,t) (ForallT tvar (parse-type t))] 75 | [else (error 'parse-type "invalid type")])) 76 | 77 | ;; Type Checker 78 | 79 | (define (type-check e tenv) 80 | (match e 81 | [(NumE n) (NumT)] 82 | [(BoolE b) (BoolT)] 83 | [(IdE n) (type-lookup n tenv)] 84 | [(PlusE l r) (type-check-nums l r tenv)] 85 | [(MultE l r) (type-check-nums l r tenv)] 86 | [(LamE arg-name arg-type body) 87 | (type-var-check arg-type tenv) 88 | (ArrowT arg-type (type-check body 89 | (ext-tenv (TypeBinding arg-name arg-type) tenv)))] 90 | [(AppE fun arg) 91 | (match (type-check fun tenv) 92 | [(ArrowT arg-type res-type) 93 | (if (equal? arg-type (type-check arg tenv)) 94 | res-type 95 | (type-error arg arg-type))] 96 | [else (type-error fun "function")])] 97 | [(TyLamE n body) 98 | (ForallT n (type-check body (ext-tenv (TypeVar n) tenv)))] 99 | [(TyAppE tyfun tyarg) 100 | (type-var-check tyarg tenv) 101 | (match (type-check tyfun tenv) 102 | [(ForallT n body) (type-subst n tyarg body)] 103 | [else (type-error tyfun "polymorphic function")])])) 104 | 105 | (define (type-check-nums l r tenv) 106 | (match* ((type-check l tenv) 107 | (type-check r tenv)) 108 | [((NumT) (NumT)) (NumT)] 109 | [((NumT) _) (type-error r (NumT))] 110 | [(_ _) (type-error l (NumT))])) 111 | 112 | (define (type-var-check arg-type tenv) 113 | (match arg-type 114 | [(NumT) (values)] 115 | [(BoolT) (values)] 116 | [(ArrowT arg res) 117 | (type-var-check arg tenv) (type-var-check res tenv) 118 | (values)] 119 | [(VarT id) (type-var-lookup id tenv) (values)] 120 | [(ForallT id ty) (type-var-check ty (ext-tenv (TypeVar id) tenv))])) 121 | 122 | (define (type-subst what for in) 123 | (match in 124 | [(NumT) (NumT)] 125 | [(BoolT) (BoolT)] 126 | [(ArrowT arg res) (ArrowT (type-subst what for arg) 127 | (type-subst what for res))] 128 | [(VarT n) (if (equal? what n) for in)] 129 | [(ForallT n body) 130 | (cond [(equal? what n) (ForallT n body)] 131 | [(free-type-var? n for) 132 | (define new-n (gen-name n 1 for body)) 133 | (define new-body (type-subst n (VarT new-n) body)) 134 | (type-subst what for (ForallT new-n new-body))] 135 | [else (ForallT n (type-subst what for body))])])) 136 | 137 | (define (gen-name n i for body) 138 | (let ([new-n (string->symbol (string-append (symbol->string n) 139 | (number->string i)))]) 140 | (if (or (free-type-var? new-n for) 141 | (free-type-var? new-n body)) 142 | (gen-name n (+ i 1) for body) 143 | new-n))) 144 | 145 | (define (free-type-var? n ty) 146 | (match ty 147 | [(NumT) #f] 148 | [(BoolT) #f] 149 | [(ArrowT a r) (or (free-type-var? n a) 150 | (free-type-var? n r))] 151 | [(VarT n^) (equal? n^ n)] 152 | [(ForallT n^ body) 153 | (if (equal? n n^) #f (free-type-var? n body))])) 154 | 155 | ;; Interpreter 156 | 157 | (define (interp expr env) 158 | (match expr 159 | [(IdE x) (lookup x env)] 160 | [(NumE n) (NumV n)] 161 | [(BoolE b) (BoolV b)] 162 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 163 | (NumV-n (interp r env))))] 164 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 165 | (NumV-n (interp r env))))] 166 | [(LamE n t body) (ClosureV n body env)] 167 | [(AppE fun arg) 168 | (match (interp fun env) 169 | [(ClosureV n body env*) 170 | (interp body (ext-env (Binding n (interp arg env)) env*))])] 171 | [(TyLamE n body) (PolyV body env)] 172 | [(TyAppE tyfun tyarg) 173 | (match (interp tyfun env) 174 | [(PolyV body env*) (interp body env*)])])) 175 | 176 | (define mt-env empty) 177 | (define mt-tenv empty) 178 | (define (run prog) 179 | (define prog* (parse prog)) 180 | (type-check prog* mt-tenv) 181 | (interp prog* mt-env)) 182 | 183 | ;; Test 184 | 185 | (module+ test 186 | (check-equal? (parse-type '{a -> a}) 187 | (ArrowT (VarT 'a) (VarT 'a))) 188 | 189 | (check-equal? (parse-type '{∀ {a} {a -> a}}) 190 | (ForallT 'a (ArrowT (VarT 'a) (VarT 'a)))) 191 | 192 | (check-equal? (parse '{let {[id : {∀ {a} {a -> a}} 193 | [Λ [a] {λ {[x : a]} x}]]} 194 | {+ {[@ id num] 1} {[@ id num] 2}}}) 195 | (AppE 196 | (LamE 197 | 'id 198 | (ForallT 'a (ArrowT (VarT 'a) (VarT 'a))) 199 | (PlusE 200 | (AppE (TyAppE (IdE 'id) (NumT)) (NumE 1)) 201 | (AppE (TyAppE (IdE 'id) (NumT)) (NumE 2)))) 202 | (TyLamE 'a (LamE 'x (VarT 'a) (IdE 'x))))) 203 | 204 | (check-equal? (type-check (parse '{let {[id : {∀ {a} {a -> a}} 205 | [Λ [a] {λ {[x : a]} x}]]} 206 | {+ {[@ id num] 1} {[@ id num] 2}}}) 207 | mt-tenv) 208 | (NumT)) 209 | 210 | (check-equal? (parse '{let {[x : num 4]} 211 | {let {[y : num 5]} 212 | {{{λ {[x : num]} 213 | {λ {[y : num]} 214 | {+ x y}}} x} y}}}) 215 | (AppE (LamE 'x (NumT) 216 | (AppE (LamE 'y (NumT) 217 | (AppE (AppE (LamE 'x (NumT) 218 | (LamE 'y (NumT) (PlusE (IdE 'x) (IdE 'y)))) (IdE 'x)) 219 | (IdE 'y))) (NumE 5))) (NumE 4))) 220 | 221 | (check-equal? (type-check (parse '{let {[x : num 4]} 222 | {let {[y : num 5]} 223 | {{{λ {[x : num]} 224 | {λ {[y : num]} 225 | {+ x y}}} x} y}}}) mt-tenv) 226 | (NumT)) 227 | 228 | (check-equal? (run '{let {[x : num 4]} 229 | {let {[y : num 5]} 230 | {{{λ {[x : num]} 231 | {λ {[y : num]} 232 | {+ x y}}} x} y}}}) 233 | (NumV 9)) 234 | 235 | (check-equal? (run '{let {[id : {∀ {a} {a -> a}} 236 | [Λ [a] {λ {[x : a]} x}]]} 237 | {+ {[@ id num] 1} {{[@ id {num -> num}] {λ {[x : num]} x}} 2}}}) 238 | (NumV 3)) 239 | 240 | (check-equal? (type-check 241 | (parse '{let {[f : {∀ {a} {a -> {∀ {b} {{a -> b} -> b}}}} 242 | [Λ [a] {λ {[x : a]} 243 | [Λ [b] {λ {[g : {a -> b}]} {g x}}]}]]} 244 | {[@ {[@ f num] 3} bool] {λ {[x : num]} true}}}) 245 | mt-tenv) 246 | (BoolT)) 247 | 248 | (check-equal? (run '{let {[f : {∀ {a} {a -> {∀ {b} {{a -> b} -> b}}}} 249 | [Λ [a] {λ {[x : a]} 250 | [Λ [b] {λ {[g : {a -> b}]} {g x}}]}]]} 251 | {[@ {[@ f num] 3} bool] {λ {[x : num]} true}}}) 252 | (BoolV #t)) 253 | 254 | ; Boolean Encodings 255 | 256 | (define Bool '{∀ [a] {a -> {a -> a}}}) 257 | (define True '{Λ [a] {λ {[x : a]} {λ {[y : a]} x}}}) 258 | (define False '{Λ [a] {λ {[x : a]} {λ {[y : a]} y}}}) 259 | (define And `{λ {[x : ,Bool]} {λ {[y : ,Bool]} {{[@ x ,Bool] y} ,False}}}) 260 | (define Bool->Num `{λ {[x : ,Bool]} {{[@ x num] 1} 0}}) 261 | 262 | (check-equal? (run `{let {[t : ,Bool ,True]} 263 | {let {[f : ,Bool ,False]} 264 | {let {[and : {,Bool -> {,Bool -> ,Bool}} ,And]} 265 | {,Bool->Num {{and t} f}}}}}) 266 | (NumV 0)) 267 | 268 | (check-equal? (run `{let {[t : ,Bool ,True]} 269 | {let {[f : ,Bool ,False]} 270 | {let {[and : {,Bool -> {,Bool -> ,Bool}} ,And]} 271 | {,Bool->Num {{and t} t}}}}}) 272 | (NumV 1)) 273 | ) 274 | -------------------------------------------------------------------------------- /stlc-omega.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Simply Typed Lamdba Calculus with Type Operators 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct AppE (fun arg) #:transparent) 17 | (struct LamE (arg arg-type body) #:transparent) 18 | (struct IfE (cnd thn els) #:transparent) 19 | 20 | ;; Types 21 | 22 | (struct NumT () #:transparent) 23 | (struct BoolT () #:transparent) 24 | (struct VarT (name) #:transparent) 25 | (struct OpAbsT (arg arg-kind body) #:transparent) 26 | (struct OpAppT (t1 t2) #:transparent) 27 | (struct ArrowT (arg res) #:transparent) 28 | 29 | ;; Kinds 30 | 31 | (struct StarK () #:transparent) 32 | (struct ArrowK (k1 k2) #:transparent) 33 | 34 | ;; Values 35 | 36 | (struct NumV (n) #:transparent) 37 | (struct BoolV (b) #:transparent) 38 | (struct ClosureV (arg body env) #:transparent) 39 | 40 | ;; Environment & Type Environment 41 | 42 | (struct Binding (name val) #:transparent) 43 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 44 | (define ext-env cons) 45 | 46 | (struct TypeBinding (name type) #:transparent) 47 | (struct KindBinding (name kind) #:transparent) 48 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 49 | (define kind-lookup (make-lookup 'kind-lookup KindBinding? KindBinding-name KindBinding-kind)) 50 | (define ext-tenv cons) 51 | 52 | ;; Parser 53 | 54 | (define (parse s) 55 | (match s 56 | [(? number? x) (NumE x)] 57 | ['true (BoolE #t)] 58 | ['false (BoolE #f)] 59 | [(? symbol? x) (IdE x)] 60 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 61 | [`(* ,l ,r) (MultE (parse l) (parse r))] 62 | [`(λ ([,var : ,ty]) ,body) 63 | (LamE var (parse-type ty) (parse body))] 64 | [`(let ([,var : ,ty ,val]) ,body) 65 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 66 | [`(if ,cnd ,thn ,els) 67 | (IfE (parse cnd) (parse thn) (parse els))] 68 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 69 | [else (error 'parse "invalid expression")])) 70 | 71 | (define (parse-type t) 72 | (match t 73 | ['num (NumT)] 74 | ['bool (BoolT)] 75 | [(? symbol? x) (VarT x)] 76 | [`(Λ ([,tvar : ,k]) ,tbody) 77 | (OpAbsT tvar (parse-kind k) (parse-type tbody))] 78 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 79 | [`(,t1 ,t2) (OpAppT (parse-type t1) (parse-type t2))] 80 | [else (error 'parse-type "invalid type")])) 81 | 82 | (define (parse-kind k) 83 | (match k 84 | ['* (StarK)] 85 | [`(,k1 -> ,k2) (ArrowK (parse-kind k1) (parse-kind k2))])) 86 | 87 | ;; Type Checker 88 | 89 | (define (kind-check t tenv) 90 | (match t 91 | [(NumT) (StarK)] 92 | [(BoolT) (StarK)] 93 | [(ArrowT arg ret) (StarK)] 94 | [(VarT name) (kind-lookup name tenv)] 95 | [(OpAbsT arg arg/k body) 96 | (ArrowK arg/k (kind-check body (ext-tenv (KindBinding arg arg/k) tenv)))] 97 | [(OpAppT t1 t2) 98 | (match (kind-check t1 tenv) 99 | [(ArrowK k1 k2) 100 | (if (equal? (kind-check t2 tenv) k1) 101 | k2 102 | (error 'kind-check "kinds not agree"))] 103 | [else (error 'kind-check "not an arrow kind")])])) 104 | 105 | (define (gen-name n i for body) 106 | (let ([new-n (string->symbol (string-append (symbol->string n) 107 | (number->string i)))]) 108 | (if (or (free-type-var? new-n for) 109 | (free-type-var? new-n body)) 110 | (gen-name n (+ i 1) for body) 111 | new-n))) 112 | 113 | (define (free-type-var? n ty) 114 | (match ty 115 | [(NumT) #f] 116 | [(BoolT) #f] 117 | [(ArrowT a r) 118 | (or (free-type-var? n a) (free-type-var? n r))] 119 | [(VarT n^) (equal? n^ n)] 120 | [(OpAppT t1 t2) 121 | (or (free-type-var? n t1) (free-type-var? n t2))] 122 | [(OpAbsT arg arg/k body) 123 | (if (equal? arg n) #f 124 | (free-type-var? n body))])) 125 | 126 | (define (type-subst what for in) 127 | (match in 128 | [(NumT) (NumT)] 129 | [(BoolT) (BoolT)] 130 | [(ArrowT arg res) 131 | (ArrowT (type-subst what for arg) 132 | (type-subst what for res))] 133 | [(VarT n) (if (equal? what n) for in)] 134 | [(OpAppT t1 t2) 135 | (OpAppT (type-subst what for t1) 136 | (type-subst what for t2))] 137 | [(OpAbsT arg arg/k body) 138 | (cond [(equal? arg what) in] 139 | [(free-type-var? arg for) 140 | (define new-n (gen-name arg 1 for body)) 141 | (define new-body (type-subst arg (VarT new-n) body)) 142 | (type-subst what for (OpAbsT new-n arg/k new-body))] 143 | [else (OpAbsT arg arg/k (type-subst what for body))])])) 144 | 145 | (define (type-apply t) 146 | (match t 147 | [(OpAppT t1 t2) 148 | (match (type-apply t1) 149 | [(OpAbsT arg arg/k body) (type-subst arg t2 body)] 150 | [else (error 'type-norm "can not substitute")])] 151 | [else t])) 152 | 153 | (define (type-var-alpha ty) 154 | (type-var-alpha/helper ty (simple-counter))) 155 | 156 | (define (type-var-alpha/helper ty c) 157 | (match ty 158 | [(OpAbsT arg arg/k body) 159 | (define new-n (c)) 160 | (OpAbsT new-n arg/k (type-var-alpha/helper (type-subst arg (VarT new-n) body) c))] 161 | [(ArrowT t1 t2) 162 | (ArrowT (type-var-alpha/helper t1 c) (type-var-alpha/helper t2 c))] 163 | [_ ty])) 164 | 165 | (define (type-equal? t1 t2) 166 | (define (type-equal?/OpAbsT t1 t2) 167 | (define t1/α (type-var-alpha t1)) 168 | (define t2/α (type-var-alpha t2)) 169 | (match* (t1/α t2/α) 170 | [((OpAbsT arg1 arg/k1 body1) (OpAbsT arg2 arg/k2 body2)) 171 | (and (equal? arg/k1 arg/k2) (type-equal? body1 body2))])) 172 | 173 | (define t1^ (type-apply t1)) 174 | (define t2^ (type-apply t2)) 175 | (match* (t1^ t2^) 176 | [((NumT) (NumT)) #true] 177 | [((BoolT) (BoolT)) #true] 178 | [((VarT x) (VarT y)) (equal? x y)] 179 | [((ArrowT t11 t12) (ArrowT t21 t22)) 180 | (and (type-equal? t11 t21) (type-equal? t12 t22))] 181 | [((OpAbsT _ _ _) (OpAbsT _ _ _)) 182 | (type-equal?/OpAbsT t1^ t2^)] 183 | [((OpAppT t11 t12) (OpAppT t21 t22)) 184 | (and (type-equal? t11 t21) (type-equal? t12 t22))] 185 | [(_ _) #false])) 186 | 187 | (define (typecheck-nums l r tenv) 188 | (if (and (type-equal? (NumT) (typecheck l tenv)) 189 | (type-equal? (NumT) (typecheck r tenv))) 190 | (NumT) 191 | (type-error "not a number"))) 192 | 193 | (define (typecheck exp tenv) 194 | (match exp 195 | [(NumE n) (NumT)] 196 | [(BoolE b) (BoolT)] 197 | [(PlusE l r) (typecheck-nums l r tenv)] 198 | [(MultE l r) (typecheck-nums l r tenv)] 199 | [(IdE n) (type-lookup n tenv)] 200 | [(IfE cnd thn els) 201 | (if (type-equal? (BoolT) (typecheck cnd tenv)) 202 | (let ([thn-type (typecheck thn tenv)] 203 | [els-type (typecheck els tenv)]) 204 | (if (type-equal? thn-type els-type) 205 | thn-type 206 | (type-error "types of branches not agree"))) 207 | (type-error "not a boolean"))] 208 | [(LamE arg arg-type body) 209 | (if (equal? (StarK) (kind-check arg-type tenv)) 210 | (ArrowT arg-type (typecheck body (ext-tenv (TypeBinding arg arg-type) tenv))) 211 | (error 'kind-check "not a * kind"))] 212 | [(AppE fun arg) 213 | (match (type-apply (typecheck fun tenv)) 214 | [(ArrowT atype rtype) 215 | (if (type-equal? atype (typecheck arg tenv)) 216 | rtype 217 | (type-error "argument types not agree"))] 218 | [_ (type-error "not a function")])])) 219 | 220 | ;; Interpreter 221 | 222 | (define (interp expr env) 223 | (match expr 224 | [(IdE x) (lookup x env)] 225 | [(NumE n) (NumV n)] 226 | [(BoolE b) (BoolV b)] 227 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 228 | (NumV-n (interp r env))))] 229 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 230 | (NumV-n (interp r env))))] 231 | [(LamE arg at body) (ClosureV arg body env)] 232 | [(IfE cnd thn els) 233 | (match (interp cnd env) 234 | [(BoolV #t) (interp thn env)] 235 | [(BoolV #f) (interp els env)])] 236 | [(AppE fun arg) 237 | (match (interp fun env) 238 | [(ClosureV n body env*) 239 | (interp body (ext-env (Binding n (interp arg env)) env*))])])) 240 | 241 | (define mt-env empty) 242 | (define mt-tenv empty) 243 | 244 | (define (run prog) 245 | (define prog* (parse prog)) 246 | (typecheck prog* mt-tenv) 247 | (interp prog* mt-env)) 248 | 249 | ;; Tests 250 | 251 | (module+ test 252 | (check-equal? (run '1) (NumV 1)) 253 | (check-equal? (run '{λ {[x : num]} x}) 254 | (ClosureV 'x (IdE 'x) '())) 255 | (check-equal? (run '{{λ {[x : num]} {+ x x}} 3}) 256 | (NumV 6)) 257 | (check-equal? (run '{let {[double : {num -> num} 258 | {λ {[x : num]} {+ x x}}]} 259 | {double 3}}) 260 | (NumV 6)) 261 | (check-equal? (run '{{if true 262 | {λ {[x : num]} {+ x 1}} 263 | {λ {[x : num]} {+ x 2}}} 264 | 3}) 265 | (NumV 4)) 266 | 267 | (check-equal? (type-subst 'z (NumT) 268 | (parse-type '{Λ {[x : *]} {Λ {[y : *]} {x -> {z -> y}}}})) 269 | (OpAbsT 'x (StarK) 270 | (OpAbsT 'y (StarK) (ArrowT (VarT 'x) (ArrowT (NumT) (VarT 'y)))))) 271 | 272 | (check-true (type-equal? (parse-type '{{Λ {[x : *]} {x -> x}} num}) 273 | (parse-type '{{Λ {[y : *]} {y -> y}} num}))) 274 | 275 | (check-true (type-equal? (parse-type '{{Λ {[x : *]} {x -> x}} num}) 276 | (parse-type '{num -> num}))) 277 | 278 | (check-equal? (typecheck (parse '{{λ {[id : {{Λ {[x : *]} {x -> x}} num}]} 279 | {+ 4 {id 3}}} 280 | {λ {[x : num]} x}}) 281 | empty) 282 | (NumT)) 283 | 284 | (check-equal? (run '{{λ {[id : {{Λ {[x : *]} {x -> x}} num}]} 285 | {+ 4 {id 3}}} 286 | {λ {[x : num]} x}}) 287 | (NumV 7)) 288 | 289 | (check-equal? (run '{let {[plus : {{{Λ {[x : *]} 290 | {Λ {[y : *]} 291 | {x -> {y -> x}}}} 292 | num} num} 293 | {λ {[x : num]} 294 | {λ {[y : num]} 295 | {+ x y}}}]} 296 | {{plus 1} 2}}) 297 | (NumV 3)) 298 | ) 299 | -------------------------------------------------------------------------------- /stlc-infer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; Type Inference for Simply Typed Lambda Calculus 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require racket/set) 8 | (require "share.rkt") 9 | 10 | ;; Expressions 11 | 12 | (struct NumE (n) #:transparent) 13 | (struct BoolE (b) #:transparent) 14 | (struct IdE (id) #:transparent) 15 | (struct PlusE (l r) #:transparent) 16 | (struct MultE (l r) #:transparent) 17 | (struct LamE (arg body) #:transparent) 18 | (struct AppE (fun arg) #:transparent) 19 | 20 | ;; Types 21 | 22 | (struct NumT () #:transparent) 23 | (struct BoolT () #:transparent) 24 | (struct VarT (name) #:transparent) 25 | (struct ArrowT (arg result) #:transparent) 26 | 27 | ;; Values 28 | 29 | (struct NumV (n) #:transparent) 30 | (struct BoolV (b) #:transparent) 31 | (struct ClosureV (arg body env) #:transparent) 32 | 33 | ;; Environment & Type Environment 34 | 35 | (struct Binding (name val) #:transparent) 36 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 37 | (define ext-env cons) 38 | 39 | (struct TypeBinding (name type) #:transparent) 40 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 41 | (define ext-tenv cons) 42 | 43 | ;; Parsers 44 | 45 | (define (parse s) 46 | (match s 47 | [(? number? x) (NumE x)] 48 | ['true (BoolE #t)] 49 | ['false (BoolE #f)] 50 | [(? symbol? x) (IdE x)] 51 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 52 | [`(* ,l ,r) (MultE (parse l) (parse r))] 53 | [`(let ([,var ,val]) ,body) 54 | (AppE (LamE var (parse body)) (parse val))] 55 | [`(λ (,var) ,body) (LamE var (parse body))] 56 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 57 | [else (error 'parse "invalid expression")])) 58 | 59 | ;; Fresh Number Generator 60 | 61 | (define (counter) 62 | (define count 0) 63 | (define (inner) 64 | (set! count (add1 count)) 65 | count) 66 | inner) 67 | 68 | (define fresh-n (counter)) 69 | 70 | ;; Type Inference 71 | 72 | (struct Eq (fst snd) #:transparent) 73 | 74 | (define (type-subst in src dst) 75 | (match in 76 | [(NumT) in] 77 | [(BoolT) in] 78 | [(VarT x) (if (equal? src in) dst in)] 79 | [(ArrowT t1 t2) (ArrowT (type-subst t1 src dst) 80 | (type-subst t2 src dst))])) 81 | 82 | (define (unify/subst eqs src dst) 83 | (cond [(empty? eqs) eqs] 84 | [else (define eq (first eqs)) 85 | (define eqfst (Eq-fst eq)) 86 | (define eqsnd (Eq-snd eq)) 87 | (cons (Eq (type-subst eqfst src dst) 88 | (type-subst eqsnd src dst)) 89 | (unify/subst (rest eqs) src dst))])) 90 | 91 | (define (occurs? t in) 92 | (match in 93 | [(NumT) #f] 94 | [(ArrowT at rt) (or (occurs? t at) (occurs? t rt))] 95 | [(VarT x) (equal? t in)])) 96 | 97 | (define not-occurs? (compose not occurs?)) 98 | 99 | (define (unify-error t1 t2) 100 | (error 'type-error "can not unify: ~a and ~a" t1 t2)) 101 | 102 | (define (unify/helper substs result) 103 | (match substs 104 | ['() result] 105 | [(list (Eq fst snd) rest ...) 106 | (match* (fst snd) 107 | [((VarT x) t) 108 | (if (not-occurs? fst snd) 109 | (unify/helper (unify/subst rest fst snd) (cons (Eq fst snd) result)) 110 | (unify-error fst snd))] 111 | [(t (VarT x)) 112 | (if (not-occurs? snd fst) 113 | (unify/helper (unify/subst rest snd fst) (cons (Eq snd fst) result)) 114 | (unify-error snd fst))] 115 | [((ArrowT t1 t2) (ArrowT t3 t4)) 116 | (unify/helper `(,(Eq t1 t3) ,(Eq t2 t4) ,@rest) result)] 117 | [(x x) (unify/helper rest result)] 118 | [(_ _) (unify-error fst snd)])])) 119 | 120 | (define (unify substs) (unify/helper (set->list substs) (list))) 121 | 122 | (define (type-infer exp tenv const) 123 | (match exp 124 | [(NumE n) (values (NumT) const)] 125 | [(BoolE b) (values (BoolT) const)] 126 | [(PlusE l r) 127 | (define-values (lty lconst) (type-infer l tenv (set))) 128 | (define-values (rty rconst) (type-infer r tenv (set))) 129 | (values (NumT) 130 | (set-add (set-add (set-union lconst rconst) (Eq lty (NumT))) (Eq rty (NumT))))] 131 | [(MultE l r) 132 | (define-values (lty lconst) (type-infer l tenv (set))) 133 | (define-values (rty rconst) (type-infer r tenv (set))) 134 | (values (NumT) 135 | (set-add (set-add (set-union lconst rconst) (Eq lty (NumT))) (Eq rty (NumT))))] 136 | [(IdE x) 137 | (values (type-lookup x tenv) const)] 138 | [(LamE arg body) 139 | (define new-tvar (VarT (fresh-n))) 140 | (define-values (bty bconst) 141 | (type-infer body (ext-tenv (TypeBinding arg new-tvar) tenv) const)) 142 | (values (ArrowT new-tvar bty) bconst)] 143 | [(AppE fun arg) 144 | (define-values (funty funconst) (type-infer fun tenv (set))) 145 | (define-values (argty argconst) (type-infer arg tenv (set))) 146 | (define new-tvar (VarT (fresh-n))) 147 | (values new-tvar (set-add (set-union funconst argconst) (Eq funty (ArrowT argty new-tvar))))])) 148 | 149 | (define (reify substs ty) 150 | (define (lookup/default x sts) 151 | (match sts 152 | ['() x] 153 | [(list (Eq fst snd) rest ...) 154 | (if (equal? fst x) 155 | (lookup/default snd substs) 156 | (lookup/default x rest))])) 157 | 158 | (match ty 159 | [(NumT) (NumT)] 160 | [(BoolT) (BoolT)] 161 | [(VarT x) 162 | (define ans (lookup/default ty substs)) 163 | (if (ArrowT? ans) (reify substs ans) ans)] 164 | [(ArrowT t1 t2) 165 | (ArrowT (reify substs t1) (reify substs t2))])) 166 | 167 | (define (typecheck exp tenv) 168 | (set! fresh-n (counter)) 169 | (define-values (ty constraints) (type-infer exp tenv (set))) 170 | (reify (unify constraints) ty)) 171 | 172 | ;; Interpreter 173 | 174 | (define (interp expr env) 175 | (match expr 176 | [(IdE x) (lookup x env)] 177 | [(NumE n) (NumV n)] 178 | [(BoolE b) (BoolV b)] 179 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) (NumV-n (interp r env))))] 180 | [(MultE l r) (NumV (* (NumV-n (interp l env)) (NumV-n (interp r env))))] 181 | [(LamE arg body) (ClosureV arg body env)] 182 | [(AppE fun arg) 183 | (match (interp fun env) 184 | [(ClosureV n body env*) (interp body (ext-env (Binding n (interp arg env)) env*))])])) 185 | 186 | (define mt-env empty) 187 | (define mt-tenv empty) 188 | 189 | (define (run prog) 190 | (define prog* (parse prog)) 191 | (typecheck prog* mt-tenv) 192 | (interp prog* mt-env)) 193 | 194 | ;; Tests 195 | 196 | (module+ test 197 | (check-equal? (type-subst (VarT 'x) (VarT 'x) (NumT)) 198 | (NumT)) 199 | 200 | (check-equal? (unify/subst (list (Eq (VarT 'a) (NumT))) (VarT 'a) (NumT)) 201 | (list (Eq (NumT) (NumT)))) 202 | 203 | (check-equal? (unify/subst (list (Eq (VarT 'a) (VarT 'a))) (VarT 'a) (NumT)) 204 | (list (Eq (NumT) (NumT)))) 205 | 206 | (check-equal? (unify/subst (list (Eq (VarT 'b) (VarT 'a))) (VarT 'a) (NumT)) 207 | (list (Eq (VarT 'b) (NumT)))) 208 | 209 | (check-equal? (unify/helper (list (Eq (ArrowT (VarT 't1) (VarT 't1)) 210 | (ArrowT (NumT) (VarT 't2)))) 211 | (list)) 212 | (list (Eq (VarT 't2) (NumT)) (Eq (VarT 't1) (NumT)))) 213 | 214 | (check-equal? (unify/helper (list (Eq (VarT 'a1) (ArrowT (NumT) (VarT 'a2))) 215 | (Eq (ArrowT (VarT 'a1) (VarT 'a2)) 216 | (ArrowT (ArrowT (VarT 'a3) (VarT 'a3)) (VarT 'a4)))) 217 | (list)) 218 | (list (Eq (VarT 'a4) (NumT)) (Eq (VarT 'a2) (NumT)) 219 | (Eq (VarT 'a3) (NumT)) (Eq (VarT 'a1) (ArrowT (NumT) (VarT 'a2))))) 220 | 221 | (check-exn exn:fail? 222 | (λ () (unify (list (Eq (VarT 'a1) (ArrowT (VarT 'a1) (VarT 'a2))))))) 223 | 224 | (check-values-equal? (type-infer (parse '{λ {x} {+ x 1}}) empty (set)) 225 | (values (ArrowT (VarT 1) (NumT)) 226 | (set (Eq (NumT) (NumT)) (Eq (VarT 1) (NumT))))) 227 | 228 | (check-values-equal? (type-infer (parse '{λ {x} {λ {y} {+ x y}}}) empty (set)) 229 | (values (ArrowT (VarT 2) (ArrowT (VarT 3) (NumT))) 230 | (set (Eq (VarT 3) (NumT)) (Eq (VarT 2) (NumT))))) 231 | 232 | (check-values-equal? (type-infer (parse '{{λ {x} x} 1}) empty (set)) 233 | (values (VarT 5) 234 | (set (Eq (ArrowT (VarT 4) (VarT 4)) (ArrowT (NumT) (VarT 5)))))) 235 | 236 | (check-values-equal? (type-infer (parse '{{λ {f} {f 0}} {λ {x} x}}) empty (set)) 237 | (values (VarT 9) 238 | (set (Eq (VarT 6) (ArrowT (NumT) (VarT 7))) 239 | (Eq (ArrowT (VarT 6) (VarT 7)) 240 | (ArrowT (ArrowT (VarT 8) (VarT 8)) (VarT 9)))))) 241 | 242 | (check-values-equal? (type-infer (parse '{λ {x} x}) empty (set)) 243 | (values (ArrowT (VarT 10) (VarT 10)) 244 | (set))) 245 | 246 | (check-equal? (typecheck (parse '{{λ {f} {f 0}} {λ {x} x}}) mt-tenv) 247 | (NumT)) 248 | 249 | (check-equal? (typecheck (parse '{λ {x} {λ {y} {+ x y}}}) mt-tenv) 250 | (ArrowT (NumT) (ArrowT (NumT) (NumT)))) 251 | 252 | ; λf.λu.u (f u) :: ((a -> b) -> a) -> (a -> b) -> b 253 | (check-equal? (typecheck (parse '{λ {f} {λ {u} {u {f u}}}}) mt-tenv) 254 | (ArrowT (ArrowT (ArrowT (VarT 3) (VarT 4)) (VarT 3)) 255 | (ArrowT (ArrowT (VarT 3) (VarT 4)) (VarT 4)))) 256 | 257 | ; λx.λy.x (x y) :: (a -> a) -> a -> a 258 | (check-equal? (typecheck (parse '{λ {x} {λ {y} {x {x y}}}}) mt-tenv) 259 | (ArrowT (ArrowT (VarT 2) (VarT 2)) 260 | (ArrowT (VarT 2) (VarT 2)))) 261 | 262 | ; λx.λy.x (y x) :: (a -> b) -> ((a -> b) -> a) -> b 263 | (check-equal? (typecheck (parse '{λ {x} {λ {y} {x {y x}}}}) mt-tenv) 264 | (ArrowT 265 | (ArrowT (VarT 3) (VarT 4)) 266 | (ArrowT (ArrowT (ArrowT (VarT 3) (VarT 4)) (VarT 3)) 267 | (VarT 4)))) 268 | 269 | ;; λx.λy.y (y x) :: a -> (a -> a) -> a 270 | (check-equal? (typecheck (parse '{λ {x} {λ {y} {y {y x}}}}) mt-tenv) 271 | (ArrowT (VarT 4) (ArrowT (ArrowT (VarT 4) (VarT 4)) (VarT 4)))) 272 | 273 | (check-equal? (run '{{{λ {x} {λ {y} {+ x y}}} 3} 7}) 274 | (NumV 10)) 275 | 276 | ;; (a -> (b -> c)) -> (a -> b) -> (a -> c) 277 | (define S '{λ {x} {λ {y} {λ {z} {{x z} {y z}}}}}) 278 | (check-equal? (typecheck (parse S) mt-tenv) 279 | (ArrowT (ArrowT (VarT 3) (ArrowT (VarT 5) (VarT 6))) 280 | (ArrowT (ArrowT (VarT 3) (VarT 5)) 281 | (ArrowT (VarT 3) (VarT 6))))) 282 | 283 | ;; a -> b -> a 284 | (define K '{λ {x} {λ {y} x}}) 285 | (check-equal? (typecheck (parse K) mt-tenv) 286 | (ArrowT (VarT 1) (ArrowT (VarT 2) (VarT 1)))) 287 | 288 | ;; (a -> b) -> (a -> a) 289 | (check-equal? (typecheck (parse `(,S ,K)) mt-tenv) 290 | (ArrowT (ArrowT (VarT 6) (VarT 5)) (ArrowT (VarT 6) (VarT 6)))) 291 | 292 | ;; a -> a 293 | (check-equal? (typecheck (parse `((,S ,K) ,K)) mt-tenv) 294 | (ArrowT (VarT 6) (VarT 6))) 295 | 296 | (check-exn exn:fail? (λ () (typecheck (parse '{{λ {id} {{id id} 3}} {λ {x} x}}) mt-tenv))) 297 | 298 | (check-exn exn:fail? (λ () (typecheck (parse '{λ {x} {λ {y} {{x y} x}}}) mt-tenv))) 299 | 300 | (check-exn exn:fail? (λ () (run '{{λ {x} {x x}} {λ {x} {x x}}}))) 301 | 302 | (check-exn exn:fail? (λ () (run '{+ 3 true}))) 303 | ) 304 | -------------------------------------------------------------------------------- /systemf+ext.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; System F with Existential Types and Product Types 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Values 10 | 11 | (struct NumV (n) #:transparent) 12 | (struct BoolV (b) #:transparent) 13 | (struct ClosureV (arg body env) #:transparent) 14 | (struct PolyV (body env) #:transparent) 15 | (struct PackV (body concrete/t tvar ext/t) #:transparent) 16 | (struct ProdV (fst snd) #:transparent) 17 | 18 | ;; Expressions 19 | 20 | (struct NumE (n) #:transparent) 21 | (struct BoolE (b) #:transparent) 22 | (struct IdE (id) #:transparent) 23 | (struct PlusE (l r) #:transparent) 24 | (struct MultE (l r) #:transparent) 25 | (struct LamE (arg arg-type body) #:transparent) 26 | (struct AppE (fun arg) #:transparent) 27 | (struct TyLamE (arg body) #:transparent) 28 | (struct TyAppE (tyfun tyarg) #:transparent) 29 | 30 | (struct ProdE (fst snd) #:transparent) 31 | (struct FstE (p) #:transparent) 32 | (struct SndE (p) #:transparent) 33 | 34 | (struct PackE (body conc/t tvar ext/t) #:transparent) 35 | (struct UnPackE (tvar pvar pack body) #:transparent) 36 | 37 | ;; Types 38 | 39 | (struct NumT () #:transparent) 40 | (struct BoolT () #:transparent) 41 | (struct ArrowT (arg result) #:transparent) 42 | (struct VarT (name) #:transparent) 43 | (struct ForallT (name tbody) #:transparent) 44 | (struct ExtT (name tbody) #:transparent) 45 | (struct ProdT (fst/t snd/t) #:transparent) 46 | 47 | ;; Environment & Type Environment 48 | 49 | (struct Binding (name val) #:transparent) 50 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 51 | (define ext-env cons) 52 | 53 | (struct TypeVar (id) #:transparent) 54 | (struct TypeBinding (name type) #:transparent) 55 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 56 | (define type-var-lookup (make-lookup 'type-var-lookup TypeVar? TypeVar-id TypeVar-id)) 57 | (define ext-tenv cons) 58 | 59 | ;; Parser 60 | 61 | (define (parse s) 62 | (match s 63 | [(? number? x) (NumE x)] 64 | ['true (BoolE #t)] 65 | ['false (BoolE #f)] 66 | [(? symbol? x) (IdE x)] 67 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 68 | [`(* ,l ,r) (MultE (parse l) (parse r))] 69 | [`(let ([,var : ,ty ,val]) ,body) 70 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 71 | [`(λ ([,var : ,ty]) ,body) 72 | (LamE var (parse-type ty) (parse body))] 73 | [`(fst ,e) (FstE (parse e))] 74 | [`(snd ,e) (SndE (parse e))] 75 | [`(,l × ,r) (ProdE (parse l) (parse r))] 76 | ; Type Abstraction 77 | [`(Λ [,tvar] ,body) (TyLamE tvar (parse body))] 78 | [`(@ ,tyfun ,tyarg) (TyAppE (parse tyfun) (parse-type tyarg))] 79 | ; Existential Types 80 | [`(pack [,ct] ,body : (∃ [,atvar] ,tbody)) 81 | (PackE (parse body) (parse-type ct) atvar (parse-type tbody))] 82 | [`(unpack ([,tvar] [,pvar ,pack]) ,body) 83 | (UnPackE tvar pvar (parse pack) (parse body))] 84 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 85 | [else (error 'parse "invalid expression")])) 86 | 87 | (define (parse-type t) 88 | (match t 89 | ['num (NumT)] 90 | ['bool (BoolT)] 91 | [(? symbol? tvar) (VarT tvar)] 92 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 93 | [`(∀ (,tvar) ,t) (ForallT tvar (parse-type t))] 94 | [`(∃ (,tvar) ,t) (ExtT tvar (parse-type t))] 95 | [`(,tyfst × ,tysnd) (ProdT (parse-type tyfst) (parse-type tysnd))] 96 | [else (error 'parse-type "invalid type")])) 97 | 98 | ;; Type Checker 99 | 100 | (define (typecheck e tenv) 101 | (match e 102 | [(NumE n) (NumT)] 103 | [(BoolE b) (BoolT)] 104 | [(IdE n) (type-lookup n tenv)] 105 | [(PlusE l r) (typecheck-nums l r tenv)] 106 | [(MultE l r) (typecheck-nums l r tenv)] 107 | [(ProdE l r) (ProdT (typecheck l tenv) 108 | (typecheck r tenv))] 109 | [(FstE p) (ProdT-fst/t (typecheck p tenv))] 110 | [(SndE p) (ProdT-snd/t (typecheck p tenv))] 111 | [(LamE arg-name arg-type body) 112 | (type-var-check arg-type tenv) 113 | (ArrowT arg-type (typecheck body 114 | (ext-tenv (TypeBinding arg-name arg-type) tenv)))] 115 | [(AppE fun arg) 116 | (match (typecheck fun tenv) 117 | [(ArrowT arg-type res-type) 118 | (if (equal? arg-type (typecheck arg tenv)) 119 | res-type 120 | (type-error arg arg-type))] 121 | [else (type-error fun "function")])] 122 | [(TyLamE n body) 123 | (ForallT n (typecheck body (ext-tenv (TypeVar n) tenv)))] 124 | [(TyAppE tyfun tyarg) 125 | (type-var-check tyarg tenv) 126 | (match (typecheck tyfun tenv) 127 | [(ForallT n body) (type-subst n tyarg body)] 128 | [else (type-error tyfun "polymorphic function")])] 129 | [(PackE body ct tvar ext) 130 | (type-var-check ct tenv) 131 | (define tybody (typecheck body tenv)) 132 | (if (equal? tybody (type-subst tvar ct ext)) 133 | (ExtT tvar ext) 134 | (type-error "types not agree"))] 135 | [(UnPackE tvar pvar pack body) 136 | (match (typecheck pack tenv) 137 | [(ExtT n ext) 138 | (typecheck body (ext-tenv (TypeBinding pvar 139 | (type-subst n (VarT tvar) ext)) 140 | (ext-tenv (TypeVar tvar) tenv)))] 141 | [else (type-error pack "package value")])])) 142 | 143 | (define (typecheck-nums l r tenv) 144 | (match* ((typecheck l tenv) 145 | (typecheck r tenv)) 146 | [((NumT) (NumT)) (NumT)] 147 | [((NumT) _) (type-error r (NumT))] 148 | [(_ _) (type-error l (NumT))])) 149 | 150 | (define (type-var-check arg-type tenv) 151 | (match arg-type 152 | [(NumT) (values)] 153 | [(BoolT) (values)] 154 | [(ProdT lhs rhs) 155 | (type-var-check lhs tenv) (type-var-check rhs tenv) 156 | (values)] 157 | [(ArrowT arg res) 158 | (type-var-check arg tenv) (type-var-check res tenv) 159 | (values)] 160 | [(VarT id) (type-var-lookup id tenv) (values)] 161 | [(ForallT id ty) (type-var-check ty (ext-tenv (TypeVar id) tenv))] 162 | [(ExtT id ty) (type-var-check ty (ext-tenv (TypeVar id) tenv))])) 163 | 164 | (define (type-subst what for in) 165 | (match in 166 | [(NumT) (NumT)] 167 | [(BoolT) (BoolT)] 168 | [(ArrowT arg res) (ArrowT (type-subst what for arg) 169 | (type-subst what for res))] 170 | [(VarT n) (if (equal? what n) for in)] 171 | [(ProdT fst snd) (ProdT (type-subst what for fst) 172 | (type-subst what for snd))] 173 | [(ExtT n body) 174 | (cond [(equal? what n) (ExtT n body)] 175 | [(free-type-var? n for) 176 | (define new-n (gen-name n 1 for body)) 177 | (define new-body (type-subst n (VarT new-n) body)) 178 | (type-subst what for (ExtT new-n new-body))] 179 | [else (ExtT n (type-subst what for body))])] 180 | [(ForallT n body) 181 | (cond [(equal? what n) (ForallT n body)] 182 | [(free-type-var? n for) 183 | (define new-n (gen-name n 1 for body)) 184 | (define new-body (type-subst n (VarT new-n) body)) 185 | (type-subst what for (ForallT new-n new-body))] 186 | [else (ForallT n (type-subst what for body))])])) 187 | 188 | (define (gen-name n i for body) 189 | (let ([new-n (string->symbol (string-append (symbol->string n) 190 | (number->string i)))]) 191 | (if (or (free-type-var? new-n for) 192 | (free-type-var? new-n body)) 193 | (gen-name n (+ i 1) for body) 194 | new-n))) 195 | 196 | (define (free-type-var? n ty) 197 | (match ty 198 | [(NumT) #f] 199 | [(BoolT) #f] 200 | [(ProdT fst snd) 201 | (or (free-type-var? n fst) (free-type-var? n snd))] 202 | [(ArrowT a r) 203 | (or (free-type-var? n a) (free-type-var? n r))] 204 | [(VarT n^) (equal? n^ n)] 205 | [(ForallT n^ body) 206 | (if (equal? n n^) #f (free-type-var? n body))] 207 | [(ExtT n^ body) 208 | (if (equal? n n^) #f (free-type-var? n body))])) 209 | 210 | ;; Interpreter 211 | 212 | (define (interp expr env) 213 | (match expr 214 | [(IdE x) (lookup x env)] 215 | [(NumE n) (NumV n)] 216 | [(BoolE b) (BoolV b)] 217 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 218 | (NumV-n (interp r env))))] 219 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 220 | (NumV-n (interp r env))))] 221 | [(FstE p) (ProdV-fst (interp p env))] 222 | [(SndE p) (ProdV-snd (interp p env))] 223 | [(ProdE l r) (ProdV (interp l env) 224 | (interp r env))] 225 | [(LamE n t body) (ClosureV n body env)] 226 | [(AppE fun arg) 227 | (match (interp fun env) 228 | [(ClosureV n body env*) 229 | (interp body (ext-env (Binding n (interp arg env)) env*))])] 230 | [(TyLamE n body) (PolyV body env)] 231 | [(TyAppE tyfun tyarg) 232 | (match (interp tyfun env) 233 | [(PolyV body env*) (interp body env*)])] 234 | [(PackE body conc/t tvar ext/t) 235 | (PackV (interp body env) conc/t tvar ext/t)] 236 | [(UnPackE new-tvar pvar pack body) 237 | (match (interp pack env) 238 | [(PackV p conc/t tvar ext/t) 239 | (interp body (ext-env (Binding pvar p) env))])])) 240 | 241 | (define mt-env empty) 242 | (define mt-tenv empty) 243 | (define (run prog) 244 | (define prog* (parse prog)) 245 | (typecheck prog* mt-tenv) 246 | (interp prog* mt-env)) 247 | 248 | ;; Test 249 | 250 | (module+ test 251 | (check-equal? (parse-type '{a -> a}) 252 | (ArrowT (VarT 'a) (VarT 'a))) 253 | 254 | (check-equal? (parse-type '{∀ {a} {a -> a}}) 255 | (ForallT 'a (ArrowT (VarT 'a) (VarT 'a)))) 256 | 257 | (check-equal? (parse '{let {[id : {∀ {a} {a -> a}} 258 | [Λ [a] {λ {[x : a]} x}]]} 259 | {+ {[@ id num] 1} {[@ id num] 2}}}) 260 | (AppE 261 | (LamE 262 | 'id 263 | (ForallT 'a (ArrowT (VarT 'a) (VarT 'a))) 264 | (PlusE 265 | (AppE (TyAppE (IdE 'id) (NumT)) (NumE 1)) 266 | (AppE (TyAppE (IdE 'id) (NumT)) (NumE 2)))) 267 | (TyLamE 'a (LamE 'x (VarT 'a) (IdE 'x))))) 268 | 269 | (check-equal? (typecheck (parse '{let {[id : {∀ {a} {a -> a}} 270 | [Λ [a] {λ {[x : a]} x}]]} 271 | {+ {[@ id num] 1} {[@ id num] 2}}}) 272 | mt-tenv) 273 | (NumT)) 274 | 275 | (check-equal? (parse '{let {[x : num 4]} 276 | {let {[y : num 5]} 277 | {{{λ {[x : num]} 278 | {λ {[y : num]} 279 | {+ x y}}} x} y}}}) 280 | (AppE (LamE 'x (NumT) 281 | (AppE (LamE 'y (NumT) 282 | (AppE (AppE (LamE 'x (NumT) 283 | (LamE 'y (NumT) (PlusE (IdE 'x) (IdE 'y)))) (IdE 'x)) 284 | (IdE 'y))) (NumE 5))) (NumE 4))) 285 | 286 | (check-equal? (typecheck (parse '{let {[x : num 4]} 287 | {let {[y : num 5]} 288 | {{{λ {[x : num]} 289 | {λ {[y : num]} 290 | {+ x y}}} x} y}}}) mt-tenv) 291 | (NumT)) 292 | 293 | (check-equal? (run '{let {[x : num 4]} 294 | {let {[y : num 5]} 295 | {{{λ {[x : num]} 296 | {λ {[y : num]} 297 | {+ x y}}} x} y}}}) 298 | (NumV 9)) 299 | 300 | (check-equal? (run '{let {[id : {∀ {a} {a -> a}} 301 | [Λ [a] {λ {[x : a]} x}]]} 302 | {+ {[@ id num] 1} {{[@ id {num -> num}] {λ {[x : num]} x}} 2}}}) 303 | (NumV 3)) 304 | 305 | (check-equal? (typecheck 306 | (parse '{let {[f : {∀ {a} {a -> {∀ {b} {{a -> b} -> b}}}} 307 | [Λ [a] {λ {[x : a]} 308 | [Λ [b] {λ {[g : {a -> b}]} {g x}}]}]]} 309 | {[@ {[@ f num] 3} bool] {λ {[x : num]} true}}}) 310 | mt-tenv) 311 | (BoolT)) 312 | 313 | (check-equal? (run '{let {[f : {∀ {a} {a -> {∀ {b} {{a -> b} -> b}}}} 314 | [Λ [a] {λ {[x : a]} 315 | [Λ [b] {λ {[g : {a -> b}]} {g x}}]}]]} 316 | {[@ {[@ f num] 3} bool] {λ {[x : num]} true}}}) 317 | (BoolV #t)) 318 | 319 | ;; Boolean Encodings 320 | 321 | (define Bool '{∀ [a] {a -> {a -> a}}}) 322 | (define True '{Λ [a] {λ {[x : a]} {λ {[y : a]} x}}}) 323 | (define False '{Λ [a] {λ {[x : a]} {λ {[y : a]} y}}}) 324 | (define And `{λ {[x : ,Bool]} {λ {[y : ,Bool]} {{[@ x ,Bool] y} ,False}}}) 325 | (define Bool->Num `{λ {[x : ,Bool]} {{[@ x num] 1} 0}}) 326 | 327 | (check-equal? (run `{let {[t : ,Bool ,True]} 328 | {let {[f : ,Bool ,False]} 329 | {let {[and : {,Bool -> {,Bool -> ,Bool}} ,And]} 330 | {,Bool->Num {{and t} f}}}}}) 331 | (NumV 0)) 332 | 333 | (check-equal? (run `{let {[t : ,Bool ,True]} 334 | {let {[f : ,Bool ,False]} 335 | {let {[and : {,Bool -> {,Bool -> ,Bool}} ,And]} 336 | {,Bool->Num {{and t} t}}}}}) 337 | (NumV 1)) 338 | 339 | ;; Test Existential Types 340 | 341 | (check-equal? (parse '{pack [{num × bool}] {λ {[x : num]} {x × false}} : 342 | {∃ [a] {num -> a}}}) 343 | (PackE 344 | (LamE 'x (NumT) (ProdE (IdE 'x) (BoolE #f))) 345 | (ProdT (NumT) (BoolT)) 346 | 'a 347 | (ArrowT (NumT) (VarT 'a)))) 348 | 349 | (check-equal? (parse-type '{∃ [a] {num -> a}}) 350 | (ExtT 'a (ArrowT (NumT) (VarT 'a)))) 351 | 352 | (check-equal? (typecheck (parse '{pack [{num × bool}] {λ {[x : num]} {x × false}} : 353 | {∃ [a] {num -> a}}}) empty) 354 | (ExtT 'a (ArrowT (NumT) (VarT 'a)))) 355 | 356 | (check-equal? (parse '{unpack ([b] [x {pack [{num × bool}] 357 | {λ {[x : num]} {x × false}} : {∃ [a] {num -> a}}}]) 358 | {x 3}}) 359 | (UnPackE 360 | 'b 361 | 'x 362 | (PackE 363 | (LamE 'x (NumT) (ProdE (IdE 'x) (BoolE #f))) 364 | (ProdT (NumT) (BoolT)) 365 | 'a 366 | (ArrowT (NumT) (VarT 'a))) 367 | (AppE (IdE 'x) (NumE 3)))) 368 | 369 | ;; Define a Counter with an initial value 1, a to-num function and a increment function 370 | (define counter '{pack [num] {1 × {{λ {[x : num]} x} × {λ {[x : num]} {+ x 1}}}} : 371 | {∃ [Counter] {Counter × {{Counter -> num} × {Counter -> Counter}}}}}) 372 | 373 | (check-equal? (typecheck (parse counter) empty) 374 | (ExtT 375 | 'Counter 376 | (ProdT 377 | (VarT 'Counter) 378 | (ProdT (ArrowT (VarT 'Counter) (NumT)) (ArrowT (VarT 'Counter) (VarT 'Counter)))))) 379 | 380 | ;; Unpack Counter, retrieve the initial value, increase it and turn to num 381 | (check-equal? (typecheck (parse `{unpack {[C] [counter ,counter]} 382 | {let {[init : C {fst counter}]} 383 | {let {[inc : {C -> C} {snd {snd counter}}]} 384 | {let {[C->num : {C -> num} {fst {snd counter}}]} 385 | {C->num {inc init}}}}}}) 386 | empty) 387 | (NumT)) 388 | 389 | (check-equal? (run`{unpack {[C] [counter ,counter]} 390 | {let {[init : C {fst counter}]} 391 | {let {[inc : {C -> C} {snd {snd counter}}]} 392 | {let {[C->num : {C -> num} {fst {snd counter}}]} 393 | {C->num {inc init}}}}}}) 394 | (NumV 2)) 395 | 396 | (check-equal? (run`{unpack {[C] [counter ,counter]} 397 | {let {[init : C {fst counter}]} 398 | {let {[inc : {C -> C} {snd {snd counter}}]} 399 | {let {[C->num : {C -> num} {fst {snd counter}}]} 400 | {C->num {inc {inc {inc init}}}}}}}}) 401 | (NumV 4)) 402 | ) 403 | -------------------------------------------------------------------------------- /systemf-omega.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; System F ω 4 | ;; Guannan Wei 5 | 6 | (require rackunit) 7 | (require "share.rkt") 8 | 9 | ;; Expressions 10 | 11 | (struct NumE (n) #:transparent) 12 | (struct BoolE (b) #:transparent) 13 | (struct IdE (id) #:transparent) 14 | (struct PlusE (l r) #:transparent) 15 | (struct MultE (l r) #:transparent) 16 | (struct AppE (fun arg) #:transparent) 17 | (struct LamE (arg arg-type body) #:transparent) 18 | (struct IfE (cnd thn els) #:transparent) 19 | 20 | (struct TyLamE (arg arg-kind body) #:transparent) 21 | (struct TyAppE (tyfun tyarg) #:transparent) 22 | 23 | ;; Types 24 | 25 | (struct NumT () #:transparent) 26 | (struct BoolT () #:transparent) 27 | (struct VarT (name) #:transparent) 28 | (struct OpAbsT (arg arg-kind body) #:transparent) 29 | (struct OpAppT (t1 t2) #:transparent) 30 | (struct ArrowT (arg res) #:transparent) 31 | (struct ForallT (name kind tybody) #:transparent) 32 | 33 | ;; Kinds 34 | 35 | (struct StarK () #:transparent) 36 | (struct ArrowK (k1 k2) #:transparent) 37 | 38 | ;; Values 39 | 40 | (struct NumV (n) #:transparent) 41 | (struct BoolV (b) #:transparent) 42 | (struct PolyV (body env) #:transparent) 43 | (struct ClosureV (arg body env) #:transparent) 44 | 45 | ;; Environment & Type Environment 46 | 47 | (struct Binding (name val) #:transparent) 48 | (define lookup (make-lookup 'lookup Binding? Binding-name Binding-val)) 49 | (define ext-env cons) 50 | 51 | (struct TypeBinding (name type) #:transparent) 52 | (struct KindBinding (name kind) #:transparent) 53 | (define type-lookup (make-lookup 'type-lookup TypeBinding? TypeBinding-name TypeBinding-type)) 54 | (define kind-lookup (make-lookup 'kind-lookup KindBinding? KindBinding-name KindBinding-kind)) 55 | (define ext-tenv cons) 56 | 57 | ;; Parser 58 | 59 | (define (parse s) 60 | (match s 61 | [(? number? x) (NumE x)] 62 | ['true (BoolE #t)] 63 | ['false (BoolE #f)] 64 | [(? symbol? x) (IdE x)] 65 | [`(+ ,l ,r) (PlusE (parse l) (parse r))] 66 | [`(* ,l ,r) (MultE (parse l) (parse r))] 67 | [`(λ ([,var : ,ty]) ,body) 68 | (LamE var (parse-type ty) (parse body))] 69 | [`(let ([,var : ,ty ,val]) ,body) 70 | (AppE (LamE var (parse-type ty) (parse body)) (parse val))] 71 | [`(if ,cnd ,thn ,els) 72 | (IfE (parse cnd) (parse thn) (parse els))] 73 | [`(Λ ([,tvar : ,k]) ,body) 74 | (TyLamE tvar (parse-kind k) (parse body))] 75 | [`(Λ [,tvar] ,body) (TyLamE tvar (StarK) (parse body))] 76 | [`(@ ,tyfun ,tyarg) (TyAppE (parse tyfun) (parse-type tyarg))] 77 | [`(,fun ,arg) (AppE (parse fun) (parse arg))] 78 | [else (error 'parse "invalid expression")])) 79 | 80 | (define (parse-type t) 81 | (match t 82 | ['num (NumT)] 83 | ['bool (BoolT)] 84 | [(? symbol? x) (VarT x)] 85 | [`(Λ ([,tvar : ,k]) ,tbody) 86 | (OpAbsT tvar (parse-kind k) (parse-type tbody))] 87 | [`(,tyarg -> ,tyres) (ArrowT (parse-type tyarg) (parse-type tyres))] 88 | [`(∀ ([,tvar : ,k]) ,t) (ForallT tvar (parse-kind k) (parse-type t))] 89 | [`(∀ [,tvar] ,t) (ForallT tvar (StarK) (parse-type t))] 90 | [`(,t1 ,t2) (OpAppT (parse-type t1) (parse-type t2))] 91 | [else (error 'parse-type "invalid type")])) 92 | 93 | (define (parse-kind k) 94 | (match k 95 | ['* (StarK)] 96 | [`(,k1 -> ,k2) (ArrowK (parse-kind k1) (parse-kind k2))])) 97 | 98 | ;; Fresh Number Generator 99 | 100 | (define-values (fresh-n current-n) (counter)) 101 | 102 | (define (refresh!) 103 | (define-values (fresh-n^ current-n^) (counter)) 104 | (set! fresh-n fresh-n^) 105 | (set! current-n current-n^)) 106 | 107 | ;; Type Checker 108 | 109 | (define (kind-check t tenv) 110 | (match t 111 | [(NumT) (StarK)] 112 | [(BoolT) (StarK)] 113 | [(ArrowT arg ret) (StarK)] 114 | [(VarT name) (kind-lookup name tenv)] 115 | [(OpAbsT arg arg/k body) 116 | (ArrowK arg/k (kind-check body (ext-tenv (KindBinding arg arg/k) tenv)))] 117 | [(OpAppT t1 t2) 118 | (match (kind-check t1 tenv) 119 | [(ArrowK k1 k2) 120 | (if (equal? (kind-check t2 tenv) k1) 121 | k2 122 | (error 'kind-check "kinds not agree"))] 123 | [else (error 'kind-check "not an arrow kind")])] 124 | [(ForallT tvar k body) 125 | (match (kind-check body (ext-tenv (KindBinding tvar k) tenv)) 126 | [(StarK) (StarK)] 127 | [else (error 'kind-check "not a * kind")])])) 128 | 129 | (define (free-type-var? n ty) 130 | (match ty 131 | [(NumT) #f] 132 | [(BoolT) #f] 133 | [(ArrowT a r) 134 | (or (free-type-var? n a) (free-type-var? n r))] 135 | [(VarT n^) (equal? n^ n)] 136 | [(OpAppT t1 t2) 137 | (or (free-type-var? n t1) (free-type-var? n t2))] 138 | [(OpAbsT arg arg/k body) 139 | (if (equal? arg n) #f 140 | (free-type-var? n body))] 141 | [(ForallT n^ k body) 142 | (if (equal? n n^) #f 143 | (free-type-var? n body))])) 144 | 145 | (define (type-subst what for in) 146 | (match in 147 | [(NumT) (NumT)] 148 | [(BoolT) (BoolT)] 149 | [(ArrowT arg res) 150 | (ArrowT (type-subst what for arg) 151 | (type-subst what for res))] 152 | [(VarT n) (if (equal? what n) for in)] 153 | [(OpAppT t1 t2) 154 | (OpAppT (type-subst what for t1) 155 | (type-subst what for t2))] 156 | [(OpAbsT arg arg/k body) 157 | (cond [(equal? arg what) in] 158 | [(free-type-var? arg for) 159 | (define new-arg (fresh-n)) 160 | (define new-body (type-subst arg (VarT new-arg) body)) 161 | (type-subst what for (OpAbsT new-arg arg/k new-body))] 162 | [else (OpAbsT arg arg/k (type-subst what for body))])] 163 | [(ForallT n k body) 164 | (cond [(equal? n what) in] 165 | [(free-type-var? n for) 166 | (define new-n (fresh-n)) 167 | (define new-body (type-subst n (VarT new-n) body)) 168 | (type-subst what for (ForallT new-n k new-body))] 169 | [else (ForallT n k (type-subst what for body))])])) 170 | 171 | (define (type-apply t) 172 | (match t 173 | [(OpAppT t1 t2) 174 | (match (type-apply t1) 175 | [(OpAbsT arg arg/k body) (type-subst arg t2 body)] 176 | [else (error 'type-norm "can not substitute")])] 177 | [else t])) 178 | 179 | (define (type-var-alpha ty) 180 | (type-var-alpha/helper ty (simple-counter))) 181 | 182 | (define (type-var-alpha/helper ty c) 183 | (match ty 184 | [(OpAbsT arg arg/k body) 185 | (define new-n (c)) 186 | (OpAbsT new-n arg/k (type-var-alpha/helper (type-subst arg (VarT new-n) body) c))] 187 | [(ForallT n k body) 188 | (define new-n (c)) 189 | (ForallT new-n k (type-var-alpha/helper (type-subst n (VarT new-n) body) c))] 190 | [(ArrowT t1 t2) 191 | (ArrowT (type-var-alpha/helper t1 c) (type-var-alpha/helper t2 c))] 192 | [_ ty])) 193 | 194 | (define (type-equal? t1 t2) 195 | (define (type-equal?/OpAbsT t1 t2) 196 | (define t1/α (type-var-alpha t1)) 197 | (define t2/α (type-var-alpha t2)) 198 | (match* (t1/α t2/α) 199 | [((OpAbsT arg1 arg/k1 body1) (OpAbsT arg2 arg/k2 body2)) 200 | (and (equal? arg/k1 arg/k2) (type-equal? body1 body2))])) 201 | 202 | (define (type-equal?/ForallT t1 t2) 203 | (define t1/α (type-var-alpha t1)) 204 | (define t2/α (type-var-alpha t2)) 205 | (match* (t1/α t2/α) 206 | [((ForallT n1 k1 body1) (ForallT n2 k2 body2)) 207 | (and (equal? k1 k2) (type-equal? body1 body2))])) 208 | 209 | (define t1^ (type-apply t1)) 210 | (define t2^ (type-apply t2)) 211 | 212 | (match* (t1^ t2^) 213 | [((NumT) (NumT)) #true] 214 | [((BoolT) (BoolT)) #true] 215 | [((VarT x) (VarT y)) (equal? x y)] 216 | [((ArrowT t11 t12) (ArrowT t21 t22)) 217 | (and (type-equal? t11 t21) (type-equal? t12 t22))] 218 | [((OpAbsT _ _ _) (OpAbsT _ _ _)) 219 | (type-equal?/OpAbsT t1^ t2^)] 220 | [((ForallT _ _ _) (ForallT _ _ _)) 221 | (type-equal?/ForallT t1^ t2^)] 222 | [((OpAppT t11 t12) (OpAppT t21 t22)) 223 | (and (type-equal? t11 t21) (type-equal? t12 t22))] 224 | [(_ _) #false])) 225 | 226 | (define (typecheck-nums l r tenv) 227 | (if (and (type-equal? (NumT) (typecheck l tenv)) 228 | (type-equal? (NumT) (typecheck r tenv))) 229 | (NumT) 230 | (type-error "not a number"))) 231 | 232 | (define (typecheck exp tenv) 233 | (match exp 234 | [(NumE n) (NumT)] 235 | [(BoolE b) (BoolT)] 236 | [(PlusE l r) (typecheck-nums l r tenv)] 237 | [(MultE l r) (typecheck-nums l r tenv)] 238 | [(IdE n) (type-lookup n tenv)] 239 | [(IfE cnd thn els) 240 | (if (type-equal? (BoolT) (typecheck cnd tenv)) 241 | (let ([thn-type (typecheck thn tenv)] 242 | [els-type (typecheck els tenv)]) 243 | (if (type-equal? thn-type els-type) 244 | thn-type 245 | (type-error "types of branches not agree"))) 246 | (type-error "not a boolean"))] 247 | [(LamE arg arg-type body) 248 | (if (equal? (StarK) (kind-check arg-type tenv)) 249 | (ArrowT arg-type (typecheck body (ext-tenv (TypeBinding arg arg-type) tenv))) 250 | (error 'kind-check "not a * kind"))] 251 | [(AppE fun arg) 252 | (match (type-apply (typecheck fun tenv)) 253 | [(ArrowT atype rtype) 254 | (if (type-equal? atype (typecheck arg tenv)) 255 | rtype 256 | (type-error "argument types not agree"))] 257 | [_ (type-error fun "function")])] 258 | [(TyLamE n k body) 259 | (ForallT n k (typecheck body (ext-tenv (KindBinding n k) tenv)))] 260 | [(TyAppE tyfun tyarg) 261 | (define arg/k (kind-check tyarg tenv)) 262 | (match (type-apply (typecheck tyfun tenv)) 263 | [(ForallT n k body) 264 | (if (equal? arg/k k) (type-subst n tyarg body) 265 | (error 'kind-check "kinds not agree"))] 266 | [else (type-error tyfun "polymorphic function")])])) 267 | 268 | ;; Interpreter 269 | 270 | (define (interp expr env) 271 | (match expr 272 | [(IdE x) (lookup x env)] 273 | [(NumE n) (NumV n)] 274 | [(BoolE b) (BoolV b)] 275 | [(PlusE l r) (NumV (+ (NumV-n (interp l env)) 276 | (NumV-n (interp r env))))] 277 | [(MultE l r) (NumV (* (NumV-n (interp l env)) 278 | (NumV-n (interp r env))))] 279 | [(LamE arg at body) (ClosureV arg body env)] 280 | [(IfE cnd thn els) 281 | (match (interp cnd env) 282 | [(BoolV #t) (interp thn env)] 283 | [(BoolV #f) (interp els env)])] 284 | [(AppE fun arg) 285 | (match (interp fun env) 286 | [(ClosureV n body env*) 287 | (interp body (ext-env (Binding n (interp arg env)) env*))])] 288 | [(TyLamE n k body) (PolyV body env)] 289 | [(TyAppE tyfun tyarg) 290 | (match (interp tyfun env) 291 | [(PolyV body env*) (interp body env*)])])) 292 | 293 | (define mt-env empty) 294 | (define mt-tenv empty) 295 | 296 | (define (run prog) 297 | (refresh!) 298 | (define prog* (parse prog)) 299 | (typecheck prog* mt-tenv) 300 | (interp prog* mt-env)) 301 | 302 | ;; Tests 303 | 304 | (module+ test 305 | (check-equal? (run '1) (NumV 1)) 306 | (check-equal? (run '{λ {[x : num]} x}) 307 | (ClosureV 'x (IdE 'x) '())) 308 | (check-equal? (run '{{λ {[x : num]} {+ x x}} 3}) 309 | (NumV 6)) 310 | (check-equal? (run '{let {[double : {num -> num} 311 | {λ {[x : num]} {+ x x}}]} 312 | {double 3}}) 313 | (NumV 6)) 314 | (check-equal? (run '{{if true 315 | {λ {[x : num]} {+ x 1}} 316 | {λ {[x : num]} {+ x 2}}} 317 | 3}) 318 | (NumV 4)) 319 | 320 | (check-equal? (type-subst 'z (NumT) 321 | (parse-type '{Λ {[x : *]} {Λ {[y : *]} {x -> {z -> y}}}})) 322 | (OpAbsT 'x (StarK) 323 | (OpAbsT 'y (StarK) (ArrowT (VarT 'x) (ArrowT (NumT) (VarT 'y)))))) 324 | 325 | (check-true (type-equal? (parse-type '{{Λ {[x : *]} {x -> x}} num}) 326 | (parse-type '{{Λ {[y : *]} {y -> y}} num}))) 327 | 328 | (check-true (type-equal? (parse-type '{{Λ {[x : *]} {x -> x}} num}) 329 | (parse-type '{num -> num}))) 330 | 331 | (check-equal? (typecheck (parse '{{λ {[id : {{Λ {[x : *]} {x -> x}} num}]} 332 | {+ 4 {id 3}}} 333 | {λ {[x : num]} x}}) 334 | empty) 335 | (NumT)) 336 | 337 | (check-equal? (run '{{λ {[id : {{Λ {[x : *]} {x -> x}} num}]} 338 | {+ 4 {id 3}}} 339 | {λ {[x : num]} x}}) 340 | (NumV 7)) 341 | 342 | (check-equal? (run '{let {[plus : {{{Λ {[x : *]} 343 | {Λ {[y : *]} 344 | {x -> {y -> x}}}} 345 | num} num} 346 | {λ {[x : num]} 347 | {λ {[y : num]} 348 | {+ x y}}}]} 349 | {{plus 1} 2}}) 350 | (NumV 3)) 351 | ;;; 352 | 353 | (check-equal? (typecheck 354 | (parse '{let {[f : {∀ {a} {a -> {∀ {b} {{a -> b} -> b}}}} 355 | [Λ [a] {λ {[x : a]} 356 | [Λ [b] {λ {[g : {a -> b}]} {g x}}]}]]} 357 | {[@ {[@ f num] 3} bool] {λ {[x : num]} true}}}) 358 | mt-tenv) 359 | (BoolT)) 360 | 361 | (check-equal? (run '{let {[f : {∀ {a} {a -> {∀ {b} {{a -> b} -> b}}}} 362 | [Λ [a] {λ {[x : a]} 363 | [Λ [b] {λ {[g : {a -> b}]} {g x}}]}]]} 364 | {[@ {[@ f num] 3} bool] {λ {[x : num]} true}}}) 365 | (BoolV #t)) 366 | 367 | ; Boolean Encodings 368 | 369 | (define Bool '{∀ {[a : *]} {a -> {a -> a}}}) 370 | (define True '{Λ {[a : *]} {λ {[x : a]} {λ {[y : a]} x}}}) 371 | (define False '{Λ {[a : *]} {λ {[x : a]} {λ {[y : a]} y}}}) 372 | (define And `{λ {[x : ,Bool]} {λ {[y : ,Bool]} {{[@ x ,Bool] y} ,False}}}) 373 | (define Bool->Num `{λ {[x : ,Bool]} {{[@ x num] 1} 0}}) 374 | 375 | (check-equal? (run `{let {[t : ,Bool ,True]} 376 | {let {[f : ,Bool ,False]} 377 | {let {[and : {,Bool -> {,Bool -> ,Bool}} ,And]} 378 | {,Bool->Num {{and t} f}}}}}) 379 | (NumV 0)) 380 | 381 | (check-equal? (run `{let {[t : ,Bool ,True]} 382 | {let {[f : ,Bool ,False]} 383 | {let {[and : {,Bool -> {,Bool -> ,Bool}} ,And]} 384 | {,Bool->Num {{and t} t}}}}}) 385 | (NumV 1)) 386 | 387 | ;; Pair Encodings 388 | 389 | (define PairT '{Λ {[A : *]} {Λ {[B : *]} {∀ {[C : *]} {{A -> {B -> C}} -> C}}}}) 390 | (define make-pair '{Λ {[A : *]} {Λ {[B : *]} 391 | {λ {[x : A]} {λ {[y : B]} {Λ {[C : *]} 392 | {λ {[k : {A -> {B -> C}}]} 393 | {{k x} y}}}}}}}) 394 | 395 | (define fst `{Λ {[A : *]} {Λ {[B : *]} {λ {[p : [[,PairT A] B]]} 396 | {[@ p A] {λ {[x : A]} {λ {[y : B]} x}}}}}}) 397 | (define snd `{Λ {[A : *]} {Λ {[B : *]} {λ {[p : [[,PairT A] B]]} 398 | {[@ p B] {λ {[x : A]} {λ {[y : B]} y}}}}}}) 399 | 400 | (define PairT-num/bool `[[,PairT num] bool]) 401 | 402 | (define make-pair-num/bool `[@ [@ ,make-pair num] bool]) 403 | (define fst-num/bool `[@ [@ ,fst num] bool]) 404 | (define snd-num/bool `[@ [@ ,snd num] bool]) 405 | 406 | (check-equal? (typecheck (parse `{{,make-pair-num/bool 1} true}) empty) 407 | (type-apply (parse-type PairT-num/bool))) 408 | 409 | (check-equal? (typecheck (parse `{let {[p : ,PairT-num/bool 410 | {{,make-pair-num/bool 1} true}]} 411 | {,fst-num/bool p}}) empty) 412 | (NumT)) 413 | 414 | (check-equal? (typecheck (parse `{let {[p : ,PairT-num/bool 415 | {{,make-pair-num/bool 1} true}]} 416 | {,snd-num/bool p}}) empty) 417 | (BoolT)) 418 | 419 | (check-equal? (run `{let {[p : ,PairT-num/bool 420 | {{,make-pair-num/bool 1} true}]} 421 | {,snd-num/bool p}}) 422 | (BoolV #t)) 423 | 424 | ;; Equal under alpha renaming 425 | (check-equal? (typecheck (parse '{if true 426 | {Λ {[A : *]} {λ {[x : A]} x}} 427 | {Λ {[B : *]} {λ {[y : B]} y}}}) 428 | empty) 429 | (ForallT 'A (StarK) (ArrowT (VarT 'A) (VarT 'A)))) 430 | ) 431 | --------------------------------------------------------------------------------