commit 50540efaa52407a2828704f5c961e814bec4108d
parent bec3be8b22bfe3982a64a1c19f68c847f9b6ccb1
Author: Stephen Chang <stchang@ccs.neu.edu>
Date: Thu, 4 Jun 2015 15:22:39 -0400
add current-typecheck-relation - generalizes equality and subtype
Diffstat:
12 files changed, 56 insertions(+), 45 deletions(-)
diff --git a/tapl/ext-stlc.rkt b/tapl/ext-stlc.rkt
@@ -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
diff --git a/tapl/stlc+box.rkt b/tapl/stlc+box.rkt
@@ -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)]))
\ No newline at end of file
diff --git a/tapl/stlc+cons.rkt b/tapl/stlc+cons.rkt
@@ -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
diff --git a/tapl/stlc+lit.rkt b/tapl/stlc+lit.rkt
@@ -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"))
diff --git a/tapl/stlc+rec+sub.rkt b/tapl/stlc+rec+sub.rkt
@@ -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?))
-\ No newline at end of file
+ (current-sub? sub?)
+ (current-typecheck-relation (current-sub?)))
+\ No newline at end of file
diff --git a/tapl/stlc+sub.rkt b/tapl/stlc+sub.rkt
@@ -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)
diff --git a/tapl/stlc+tup.rkt b/tapl/stlc+tup.rkt
@@ -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))
diff --git a/tapl/stlc+var.rkt b/tapl/stlc+var.rkt
@@ -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"
diff --git a/tapl/stlc.rkt b/tapl/stlc.rkt
@@ -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: "
diff --git a/tapl/sysf.rkt b/tapl/sysf.rkt
@@ -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 ...))]
diff --git a/tapl/tests/rackunit-typechecking.rkt b/tapl/tests/rackunit-typechecking.rkt
@@ -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)
diff --git a/tapl/typecheck.rkt b/tapl/typecheck.rkt
@@ -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)
