suzanne.soy/macrotypes
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add current-typecheck-relation - generalizes equality and subtype

Browse Source
This commit is contained in:
Stephen Chang 2015-06-04 15:22:39 -04:00
parent bec3be8b22
commit 50540efaa5
12 changed files with 55 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
tapl/ext-stlc.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse syntax/stx racket/string "stx-utils.rkt")
#;(for-syntax racket/base syntax/parse syntax/stx racket/string "stx-utils.rkt")
"typecheck.rkt")
(require (prefix-in stlc: (only-in "stlc+lit.rkt" #%app #%datum))
(except-in "stlc+lit.rkt" #%app #%datum))
@ -94,7 +94,7 @@
(syntax-parse stx #:datum-literals (:)
[(_ e : ascribed-τ)
#:with (e- τ) (infer+erase #'e)
#:fail-unless ((current-type=?) #'τ #'ascribed-τ)
#:fail-unless (typecheck? #'τ #'ascribed-τ)
(format "~a does not have type ~a\n"
(syntax->datum #'e) (syntax->datum #'ascribed-τ))
(⊢ #'e- #'ascribed-τ)]))
@ -117,7 +117,7 @@
[(_ ([b:typed-binding e] ...) e_body)
#:with ((x- ...) (e- ... e_body-) (τ ... τ_body))
(infers/type-ctxt+erase #'(b ...) #'(e ... e_body))
#:fail-unless (types=? #'(b.τ ...) #'(τ ...))
#:fail-unless (typechecks? #'(b.τ ...) #'(τ ...))
(string-append
"letrec: type check fail, args have wrong type:\n"
(string-join

8
tapl/stlc+box.rkt
View File

@ -1,13 +1,13 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse syntax/stx racket/syntax racket/string
#;(for-syntax racket/base syntax/parse syntax/stx racket/syntax racket/string
"stx-utils.rkt" "typecheck.rkt")
(for-meta 2 racket/base syntax/parse racket/syntax)
#;(for-meta 2 racket/base syntax/parse racket/syntax)
"typecheck.rkt")
(require (prefix-in stlc: (only-in "stlc+cons.rkt" #%app λ))
(except-in "stlc+cons.rkt" #%app λ))
(provide (rename-out [stlc:#%app #%app] [stlc:λ λ]))
(provide (all-from-out "stlc+cons.rkt"))
(provide (except-out (all-from-out "stlc+cons.rkt") stlc:#%app stlc:λ))
(provide ref deref :=)
;; Simply-Typed Lambda Calculus, plus mutable references
@ -34,5 +34,5 @@
[(_ e_ref e)
#:with (e_ref- ((~literal Ref) τ1)) (infer+erase #'e_ref)
#:with (e- τ2) (infer+erase #'e)
#:when (type=? #'τ1 #'τ2)
#:when (typecheck? #'τ1 #'τ2)
(⊢ #'(set-box! e_ref- e-) #'Unit)]))

8
tapl/stlc+cons.rkt
View File

@ -1,14 +1,14 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse syntax/stx racket/syntax racket/string
#;(for-syntax racket/base syntax/parse syntax/stx racket/syntax racket/string
"stx-utils.rkt" "typecheck.rkt")
(for-meta 2 racket/base syntax/parse racket/syntax)
#;(for-meta 2 racket/base syntax/parse racket/syntax)
"typecheck.rkt")
(require (prefix-in stlc: (only-in "stlc+var.rkt" #%app λ let begin))
(except-in "stlc+var.rkt" #%app λ let begin))
(provide (rename-out [stlc:#%app #%app] [stlc:λ λ] [stlc:let let] [stlc:begin begin]
[cons/tc cons] [define/tc define]))
(provide (all-from-out "stlc+var.rkt"))
(provide (except-out (all-from-out "stlc+var.rkt") stlc:#%app stlc:λ stlc:let stlc:begin))
(provide nil isnil head tail)
;; Simply-Typed Lambda Calculus, plus cons
@ -45,7 +45,7 @@
[(_ e1 e2)
#:with (e1- τ1) (infer+erase #'e1)
#:with (e2- ((~literal List) τ2)) (infer+erase #'e2)
#:when ((current-type=?) #'τ1 #'τ2)
#:when (typecheck? #'τ1 #'τ2)
(⊢ #'(cons e1- e2-) #'(List τ1))]))
(define-syntax (isnil stx)
(syntax-parse stx

2
tapl/stlc+lit.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse)
#;(for-syntax racket/base syntax/parse)
"typecheck.rkt")
(require "stlc.rkt")
(provide (all-from-out "stlc.rkt"))

10
tapl/stlc+rec+sub.rkt
View File

@ -1,16 +1,17 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse racket/string syntax/stx racket/set "stx-utils.rkt")
#;(for-syntax racket/base syntax/parse racket/string syntax/stx racket/set "stx-utils.rkt")
"typecheck.rkt")
;; want to use type=? from stlc+var.rkt
(require (except-in "stlc+sub.rkt" #%app #%datum sub? type=?)
(prefix-in stlc: (only-in "stlc+sub.rkt" #%app #%datum sub?))
(except-in "stlc+var.rkt" #%app #%datum +)
(prefix-in var: (only-in "stlc+var.rkt" #%datum type=?)))
(prefix-in var: (only-in "stlc+var.rkt" #%datum)))
(provide (rename-out [stlc:#%app #%app]
[datum/tc #%datum]))
(provide (except-out (all-from-out "stlc+sub.rkt") stlc:#%app stlc:#%datum
(for-syntax stlc:sub?))
(except-out (all-from-out "stlc+var.rkt") var:#%datum (for-syntax var:type=?)))
(except-out (all-from-out "stlc+var.rkt") var:#%datum))
(provide (for-syntax sub?))
;; Simply-Typed Lambda Calculus, plus subtyping, plus records
@ -49,4 +50,5 @@
#'([l τl] ...))]
[_ #f])
(stlc:sub? τ1 τ2)))
(current-sub? sub?))
(current-sub? sub?)
(current-typecheck-relation (current-sub?)))

15
tapl/stlc+sub.rkt
View File

@ -1,12 +1,12 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse racket/string "stx-utils.rkt")
#;(for-syntax racket/base syntax/parse racket/string "stx-utils.rkt")
"typecheck.rkt")
(require (except-in "stlc+lit.rkt" #%datum + #%app)
(prefix-in stlc: (only-in "stlc+lit.rkt" #%datum)))
(provide (rename-out [app/tc #%app] [datum/tc #%datum]))
(provide (except-out (all-from-out "stlc+lit.rkt") stlc:#%datum))
(provide (for-syntax sub? subs?))
(prefix-in stlc: (only-in "stlc+lit.rkt" #%app #%datum)))
(provide (rename-out #;[app/tc #%app] [stlc:#%app #%app] [datum/tc #%datum]))
(provide (except-out (all-from-out "stlc+lit.rkt") stlc:#%app stlc:#%datum))
(provide (for-syntax sub? subs? current-sub?))
;; Simply-Typed Lambda Calculus, plus subtyping
;; Types:
@ -53,7 +53,8 @@
(and (subs? #'(t1 ...) #'(s1 ...))
((current-sub?) #'s2 #'t2))]
[_ #f])))
(current-sub? sub?)
(define current-sub? (make-parameter sub?))
(current-typecheck-relation (current-sub?))
(define (subs? τs1 τs2) (stx-andmap (current-sub?) τs1 τs2)))
#;(define-syntax (app/tc stx)
@ -64,7 +65,7 @@
(local-expand #'(stlc:#%app x ...) 'expression null))
#'res]))
(define-syntax (app/tc stx)
#;(define-syntax (app/tc stx)
(syntax-parse stx #:literals (→)
[(_ e_fn e_arg ...)
#:with (e_fn- τ_fn) (infer+erase #'e_fn)

2
tapl/stlc+tup.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse syntax/stx racket/string "stx-utils.rkt")
#;(for-syntax racket/base syntax/parse syntax/stx racket/string "stx-utils.rkt")
"typecheck.rkt")
(require (prefix-in stlc: (only-in "ext-stlc.rkt" #%app))
(except-in "ext-stlc.rkt" #%app))

9
tapl/stlc+var.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse syntax/stx racket/syntax racket/string
#;(for-syntax racket/base syntax/parse syntax/stx racket/syntax racket/string
"stx-utils.rkt" "typecheck.rkt")
(for-meta 2 racket/base syntax/parse racket/syntax)
#;(for-meta 2 racket/base syntax/parse racket/syntax)
"typecheck.rkt")
(require (prefix-in stlc: (only-in "stlc+tup.rkt" #%app λ tup proj let type=?))
(except-in "stlc+tup.rkt" #%app λ tup proj let type=?))
@ -41,6 +41,7 @@
#;[_ #f]))
(current-type=? type=?)
(current-typecheck-relation (current-type=?))
;; redefine these to use the new type=?
;; type equality = structurally recursive identifier equality
@ -97,7 +98,7 @@
#:with (∨ (l_τ τ_l) ...) #'τ+
#:with (l_match τ_match) (str-stx-assoc #'l #'((l_τ τ_l) ...))
#:with (e- τ_e) (infer+erase #'e)
#:when ((current-type=?) #'τ_match #'τ_e)
#:when (typecheck? #'τ_match #'τ_e)
(⊢ #'(list l e) #'τ+)]))
(define-syntax (case stx)
(syntax-parse stx #:datum-literals (of =>)
@ -108,7 +109,7 @@
#:fail-when (null? (syntax->list #'(l ...))) "no clauses"
#:fail-unless (= (stx-length #'(l ...)) (stx-length #'(l_x ...))) "wrong number of case clauses"
; #:fail-unless (stx-andmap stx-str=? #'(l ...) #'(l_x ...)) "case clauses not exhaustive"
#:fail-unless (types=? #'(l ...) #'(l_x ...)) "case clauses not exhaustive"
#:fail-unless (typechecks? #'(l ...) #'(l_x ...)) "case clauses not exhaustive"
#:with (((x-) e_l- τ_el) ...)
(stx-map (λ (bs e) (infer/type-ctxt+erase bs e)) #'(([x : τ_x]) ...) #'(e_l ...))
#:fail-unless (same-types? #'(τ_el ...)) "branches have different types"

9
tapl/stlc.rkt
View File

@ -1,9 +1,9 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse syntax/stx racket/string "stx-utils.rkt")
#;(for-syntax racket/base syntax/parse syntax/stx racket/string "stx-utils.rkt")
"typecheck.rkt")
(provide (rename-out [λ/tc λ] [app/tc #%app]))
(provide (for-syntax type=? types=? same-types?))
(provide (for-syntax type=? types=? same-types? current-type=?))
(provide #%module-begin #%top-interaction #%top require) ; from racket
;; Simply-Typed Lambda Calculus
@ -28,7 +28,8 @@
[((τa ...) (τb ...)) (types=? #'(τa ...) #'(τb ...))]
[_ #f]))
(current-type=? type=?)
(define current-type=? (make-parameter type=?))
(current-typecheck-relation (current-type=?))
;; type equality = structurally recursive identifier equality
;; uses the type=? in the context of τs1 instead of here
@ -57,7 +58,7 @@
#:with (→ τ ... τ_res) #'τ_fn
#:with ((e_arg- τ_arg) ...) (infers+erase #'(e_arg ...))
; #:fail-unless ((eval-syntax (datum->syntax #'e_fn 'types=?)) #'(τ ...) #'(τ_arg ...))
#:fail-unless (types=? #'(τ_arg ...) #'(τ ...))
#:fail-unless (typechecks? #'(τ_arg ...) #'(τ ...))
(string-append
(format
"Wrong number of args given to function ~a, or args have wrong type:\ngiven: "

3
tapl/sysf.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse "stx-utils.rkt")
#;(for-syntax racket/base syntax/parse "stx-utils.rkt")
"typecheck.rkt")
(require (except-in "stlc+lit.rkt" #%app type=?)
(prefix-in stlc: (only-in "stlc+lit.rkt" #%app type=?)))
@ -36,6 +36,7 @@
(substs #'(z ...) #'(y ...) #'t2))]
[_ (stlc:type=? τ1 τ2)]))
(current-type=? type=?)
(current-typecheck-relation (current-type=?))
; [(s1:str s2:str) (string=? (syntax-e #'s1) (syntax-e #'s2))]
; [(x:id y:id) (free-identifier=? τ1 τ2)]
; [((τa ...) (τb ...)) (types=? #'(τa ...) #'(τb ...))]

10
tapl/tests/rackunit-typechecking.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require (for-syntax racket/base syntax/parse syntax/srcloc rackunit)
rackunit
(require #;(for-syntax racket/base syntax/parse syntax/srcloc rackunit)
(for-syntax rackunit) rackunit
"../typecheck.rkt")
(provide (all-defined-out))
(define-for-syntax (type=? t1 t2)
#;(define-for-syntax (type=? t1 t2)
(if (current-sub?)
((current-sub?) t1 t2)
((current-type=?) t1 t2)))
@ -19,7 +19,7 @@
;; use subtyping if it's bound in the context of #'e
#;(with-handlers ([exn:fail? (λ _ ((eval-syntax (datum->syntax #'e 'type=?)) #'τ #'τ-expected+))])
((eval-syntax (datum->syntax #'e 'sub?)) #'τ #'τ-expected+))
(type=? #'τ #'τ-expected+)
(typecheck? #'τ #'τ-expected+)
(format
"Expression ~a [loc ~a:~a] has type ~a, expected ~a"
(syntax->datum #'e) (syntax-line #'e) (syntax-column #'e)
@ -34,7 +34,7 @@
#:fail-when
#;(with-handlers ([exn:fail? (λ _ ((eval-syntax (datum->syntax #'e 'type=?)) #'τ #'not-τ+))])
((eval-syntax (datum->syntax #'e 'sub?)) #'τ #'not-τ+))
(type=? #'τ #'not-τ+)
(typecheck? #'τ #'not-τ+)
(format
"(~a:~a) Expression ~a should not have type ~a"
(syntax-line stx) (syntax-column stx)

17
tapl/typecheck.rkt
View File

@ -1,10 +1,11 @@
#lang racket/base
(require
(for-syntax racket/base syntax/parse racket/list racket/syntax syntax/stx "stx-utils.rkt")
(for-meta 2 racket/base syntax/parse racket/list syntax/stx "stx-utils.rkt"))
(for-syntax racket syntax/parse racket/syntax syntax/stx "stx-utils.rkt")
#;(for-meta 2 racket/base syntax/parse racket/list syntax/stx "stx-utils.rkt"))
(provide
(for-syntax (all-defined-out))
(all-defined-out))
(all-defined-out)
(for-syntax (all-from-out racket syntax/parse racket/syntax syntax/stx "stx-utils.rkt")))
;; type checking functions/forms
@ -29,7 +30,7 @@
#'(begin
(provide τ (for-syntax τ?))
(define τ (void))
(define-for-syntax (τ? τ1) (free-identifier=? #'τ τ1)))]))
(define-for-syntax (τ? τ1) (typecheck? τ1 #'τ)))]))
(define-syntax (define-type-constructor stx)
(syntax-parse stx
@ -108,8 +109,12 @@
(syntax-parse (expand/df #`(λ #,tvs (#%expression #,e))) #:literals (#%expression)
[(lam tvs+ (#%expression e+)) (list #'tvs+ #'e+ (typeof #'e+))]))
(define current-type=? (make-parameter #f))
(define current-sub? (make-parameter #f))
(define current-typecheck-relation (make-parameter #f))
(define (typecheck? t1 t2) ((current-typecheck-relation) t1 t2))
(define (typechecks? τs1 τs2)
(stx-andmap (current-typecheck-relation) τs1 τs2))
; (define current-type=? (make-parameter #f))
; (define current-sub? (make-parameter #f))
; ;; type equality = structurally recursive identifier equality
; (define (types=? τs1 τs2)