macrotypes/sysf.rkt

#lang racket/base
(require 
  racket/match
  (for-syntax 
   racket/base syntax/parse syntax/parse/experimental/template
   syntax/stx racket/syntax racket/set
   "stx-utils.rkt")
  (for-meta 2 racket/base syntax/parse)
  "typecheck.rkt")
(require 
  (except-in 
   "stlc.rkt" 
   define-type cases begin #%app λ define
   check-type-error check-type check-type-and-result check-not-type check-equal?))
(require 
  (prefix-in stlc: 
    (only-in 
     "stlc.rkt" 
     define-type cases begin #%app λ define)))
(provide (all-from-out "stlc.rkt"))
(provide 
 define-type cases inst
 (rename-out 
  [stlc:begin begin]
  [app/tc #%app]
  [λ/tc λ] [define/tc define]))

(define-and-provide-builtin-types ∀)

(begin-for-syntax
  (define-syntax-class ∀τ #:literals (∀)
    (pattern (∀ tvs:tyvars/no-brace τbody)))
  ;; a list of types, for type instantiation
  (define-syntax-class inst-τs
    (pattern τs
     #:when (curly-parens? #'τs)
     #:fail-unless (stx-pair? #'τs) "Must provide a list of types"
     #:with (τ ...) #'τs))
  (define-syntax-class tyvars
    (pattern tvs
     #:when (curly-parens? #'tvs)
     #:fail-unless (stx-pair? #'tvs) "Must provide a list of type variables."
     #:fail-when (check-duplicate-identifier (syntax->list #'tvs))
                 "Given duplicate binders in type variable list."))
  (define-syntax-class tyvars/no-brace
    (pattern tvs
     #:fail-unless (stx-pair? #'tvs) "Must provide a list of type variables."
     #:fail-when (check-duplicate-identifier (syntax->list #'tvs))
                 "Given duplicate binders in type variable list.")))


;; define-type ----------------------------------------------------------------
(define-syntax (define-type stx)
  (syntax-parse stx #:datum-literals (variant)
    [(_ (Tycon:id X:id ...) (variant (Cons:id τ_fld ...) ...))
     #:with ((x ...) ...) (stx-map generate-temporaries #'((τ_fld ...) ...))
     #:when (Γ (type-env-extend #'([Cons (∀ (X ...) (τ_fld ... → (Tycon X ...)))] ...)))
     #'(begin ; should be racket begin
         (struct Cons (x ...) #:transparent) ...)]
    [(_ any ...) #'(stlc:define-type any ...)]))

(define-syntax (inst stx)
  (syntax-parse stx #:literals (∀)
    [(_ e τ ...)
     #:with e+ (expand/df #'e)
     #:with τ_e:∀τ (typeof #'e+)
     (⊢ #'e+ (apply-forall #'τ_e #'(τ ...)))]
    [(_ e τ ...) ; error if not ∀ type
     #:with τ_e (typeof (expand/df #'e))
     #:when 
     (type-error 
      #:src #'e
      #:msg "Could not instantiate expression ~a with non-polymorphic type ~a"
            #'e #'τ_e)
     #f]))

;; cases ----------------------------------------------------------------------
(define-syntax (cases stx)
  (syntax-parse stx #:literals (∀ →)
    [(_ τs:inst-τs e [Cons (x ...) body ... body_result] ...)
     #:with e+ (expand/df #'e)
     #:with (Cons+ ...) (stx-map expand/df #'(Cons ...))
     #:with (τ_Cons:∀τ ...) (stx-map typeof #'(Cons+ ...))
     #:with ((τ ... → τ_res) ...) 
            (stx-map (λ (∀τ) (apply-forall ∀τ #'τs)) #'(τ_Cons ...))
     ;; check constructor type in every branch matches expr being matched
     #:when (stx-andmap (λ (τ) (assert-type #'e+ τ)) #'(τ_res ...))
     #:with ((lam (x+ ...) body+ ... body_result+) ...) 
            (stx-map (λ (bods xs τs) 
                       (with-extended-type-env 
                        (stx-map list xs τs)
                        (expand/df #`(λ #,xs #,@bods))))
                     #'((body ... body_result) ...)
                     #'((x ...) ...)
                     #'((τ ...) ...))
     #:when (stx-andmap (λ (bods) (stx-andmap assert-Unit-type bods)) #'((body+ ...) ...))
     #:with (τ_result ...) (stx-map typeof #'(body_result+ ...))
     #:when (or (null? (syntax->list #'(τ_result ...)))
                (andmap (λ (τ) (type=? τ (car (syntax->list #'(τ_result ...)))))
                        (cdr (syntax->list #'(τ_result ...)))))
     (⊢ (syntax/loc stx (match e+ [(Cons+ x+ ...) body+ ... body_result+] ...))
        (car (syntax->list #'(τ_result ...))))]
    [(_ any ...) #:when (displayln "stlc:cases") #'(stlc:cases any ...)]))

;; lambda ---------------------------------------------------------------------
(define-syntax (λ/tc stx)
  (syntax-parse stx #:datum-literals (:)
    ;; most of the code from this case, except for the curly? check,
    ;; is copied from stlc:λ
    [(_ tvs:tyvars ([x:id : τ] ...) e ... e_result)
     ;; the with-extended-type-env must be outside the expand/df (instead of
     ;; around just the body) bc ow the parameter will get restored to the old
     ;; value before the local-expand happens
     #:with (lam xs e+ ... e_result+) (with-extended-type-env #'([x τ] ...)
                                        (expand/df #'(λ (x ...) e ... e_result)))
     ;; manually handle identifiers here
     ;; - since Racket has no #%var hook, ids didn't get "expanded" in the previous line
     ;;   and thus didn't get a type
     ;; TODO: can I put this somewhere else where it's more elegant?
     #:with (e++ ... e_result++) (with-extended-type-env #'([x τ] ...)
                                   (stx-map 
                                    (λ (e) (if (identifier? e) (expand/df e) e))
                                    #'(e+ ... e_result+)))
     ;; manually typecheck the implicit begin
     #:when (stx-map assert-Unit-type #'(e++ ...))
     #:with τ_body (typeof #'e_result++)
     (⊢ (syntax/loc stx (lam xs e++ ... e_result++)) #'(∀ tvs (τ ... → τ_body)))]
    [(_ any ...) #'(stlc:λ any ...)]))

; define ----------------------------------------------------------------------
(define-syntax (define/tc stx)
  (syntax-parse stx #:datum-literals (:)
    ;; most of the code from this case, except for the curly? check,
    ;; is copied from stlc:define
    [(_ (f:id tvs:tyvars [x:id : τ] ...) : τ_result e ...)
     #:when (Γ (type-env-extend #'([f (∀ tvs (τ ... → τ_result))])))
     #'(define f (λ/tc tvs ([x : τ] ...) e ...))]
    [(_ any ...) #'(stlc:define any ...)]))

; #%app -----------------------------------------------------------------------
(define-syntax (app/tc stx)
  (syntax-parse stx #:literals (→ void ∀)
    ; this case only triggered by testing forms, eg check-type
    ; more specifically, types should never get expanded, except when testing
;    [(_ → arg ...) #'(→ arg ...)]
    [(_ e_fn τs:inst-τs e_arg ...)
     #:with (e_fn+ e_arg+ ...) (stx-map expand/df #'(e_fn e_arg ...))
     #:with τ_fn:∀τ (typeof #'e_fn+)
     #:with (τ_arg ... → τ_res) (apply-forall #'τ_fn #'τs)
     #:when (stx-andmap assert-type #'(e_arg+ ...) #'(τ_arg ...))
     (⊢ (syntax/loc stx (#%app e_fn+ e_arg+ ...)) #'τ_res)]
    ;; handle type apply of non-poly fn here; just pass through
    [(_ e_fn τs:inst-τs e_arg ...)
     #'(stlc:#%app e_fn e_arg ...)]
    ;; error when e_fn has ∀ type but in instantiation vars
    [(_ e_fn e_arg ...)
     #:with e_fn+ (expand/df #'e_fn)
     #:with τ_fn:∀τ (typeof #'e_fn+)
     #:when (type-error #:src #'stx
                        #:msg "Missing type instantiation(s) in application: ~a"
                              #'(e_fn e_arg ...))
     #'#f]
    [(_ any ...) #'(stlc:#%app any ...)]))

;; testing fns ----------------------------------------------------------------
;; for now, these are duplicated from stlc.rkt: 2014-08-14
;; type checking testing: -----------------------------------------------------
(require rackunit)
(require (for-syntax rackunit "typecheck.rkt"))
(provide check-equal?)
(provide check-type-error check-type check-type-and-result check-not-type)

(define-syntax (check-type-error stx)
  (syntax-parse stx
    [(_ e)
     #:when (check-exn exn:fail? (λ () (expand/df #'e)))
     #'(void)]))

(define-syntax (check-type stx)
  (syntax-parse stx #:datum-literals (:)
    [(_ e : τ)
     #:with e+ (expand/df #'e)
     #:when (check-true (assert-type #'e+ #'τ)
                        (format "Expected type ~a but got type ~a" #'τ (typeof #'e)))
     #'(void)]))

(define-syntax (check-not-type stx)
  (syntax-parse stx #:datum-literals (:)
    [(_ e : τ)
     #:with e+ (expand/df #'e)
     #:when (check-false (type=? (typeof #'e+) #'τ)
                         (format "Expected type to not be ~a but got type ~a" #'τ (typeof #'e)))
     #'(void)]))

(define-syntax (check-type-and-result stx)
  (syntax-parse stx #:datum-literals (: =>)
    [(_ e : τ => v)
     #'(begin (check-type e : τ)
              (check-equal? e v))]))