245 lines
10 KiB
Racket
245 lines
10 KiB
Racket
#lang racket/base
|
|
|
|
(provide (except-out (all-from-out "../typecheck.rkt") -define-typed-syntax)
|
|
define-typed-syntax
|
|
(for-syntax syntax-parse/typed-syntax))
|
|
|
|
(require (rename-in
|
|
"../typecheck.rkt"
|
|
[define-typed-syntax -define-typed-syntax]
|
|
))
|
|
|
|
(module syntax-classes racket/base
|
|
(provide (all-defined-out))
|
|
(require (for-meta -1 (except-in "../typecheck.rkt" #%module-begin))
|
|
(for-meta -2 (except-in "../typecheck.rkt" #%module-begin)))
|
|
(define-syntax-class ---
|
|
[pattern (~datum --------)])
|
|
(define-syntax-class elipsis
|
|
[pattern (~literal ...)])
|
|
(define-splicing-syntax-class props
|
|
[pattern (~and (~seq stuff ...) (~seq (~seq k:id v) ...))])
|
|
(define-splicing-syntax-class ⇒-prop
|
|
#:datum-literals (⇒)
|
|
#:attributes (e-pat)
|
|
[pattern (~seq ⇒ tag:id tag-pat (tag-prop:⇒-prop) ...)
|
|
#:with e-tmp (generate-temporary)
|
|
#:with e-pat
|
|
#'(~and e-tmp
|
|
(~parse
|
|
(~and tag-prop.e-pat ... tag-pat)
|
|
(typeof #'e-tmp #:tag 'tag)))])
|
|
(define-splicing-syntax-class ⇐-prop
|
|
#:datum-literals (⇐ :)
|
|
[pattern (~seq ⇐ : τ-stx)
|
|
#:with e-tmp (generate-temporary)
|
|
#:with τ-tmp (generate-temporary)
|
|
#:with τ-exp (generate-temporary)
|
|
#:with e-pat
|
|
#'(~and e-tmp
|
|
(~parse τ-exp (get-expected-type #'e-tmp))
|
|
(~parse τ-tmp (typeof #'e-tmp))
|
|
(~parse
|
|
(~post
|
|
(~fail #:when (and (not (typecheck? #'τ-tmp #'τ-exp))
|
|
(get-orig #'e-tmp))
|
|
(format "type mismatch: expected ~a, given ~a\n expression: ~s"
|
|
(type->str #'τ-exp)
|
|
(type->str #'τ-tmp)
|
|
(syntax->datum (get-orig #'e-tmp)))))
|
|
(get-orig #'e-tmp)))])
|
|
(define-splicing-syntax-class ⇒-props
|
|
#:attributes (e-pat)
|
|
[pattern (~seq :⇒-prop)]
|
|
[pattern (~seq (p:⇒-prop) ...)
|
|
#:with e-pat #'(~and p.e-pat ...)])
|
|
(define-splicing-syntax-class ⇐-props
|
|
#:attributes (τ-stx e-pat)
|
|
[pattern (~seq :⇐-prop)]
|
|
[pattern (~seq (p:⇐-prop))
|
|
#:with τ-stx #'p.τ-stx
|
|
#:with e-pat #'p.e-pat])
|
|
(define-splicing-syntax-class id+props+≫
|
|
#:datum-literals (≫)
|
|
#:attributes ([x- 1] [ctx 1])
|
|
[pattern (~seq [x:id props:props ≫ x--:id])
|
|
#:with [x- ...] #'[x--]
|
|
#:with [ctx ...] #'[[x props.stuff ...]]]
|
|
[pattern (~seq [x:id props:props ≫ x--:id] ooo:elipsis)
|
|
#:with [x- ...] #'[x-- ooo]
|
|
#:with [ctx ...] #'[[x props.stuff ...] ooo]])
|
|
(define-splicing-syntax-class id-props+≫*
|
|
#:attributes ([x- 1] [ctx 1])
|
|
[pattern (~seq ctx1:id+props+≫ ...)
|
|
#:with [x- ...] #'[ctx1.x- ... ...]
|
|
#:with [ctx ...] #'[ctx1.ctx ... ...]])
|
|
(define-splicing-syntax-class inf
|
|
#:datum-literals (⊢ ⇒ ⇐ ≫ :)
|
|
#:attributes ([e-stx 1] [e-stx-orig 1] [e-pat 1])
|
|
[pattern (~seq [[e-stx* ≫ e-pat*] props:⇒-props] ooo:elipsis ...)
|
|
#:with e-tmp (generate-temporary #'e-pat*)
|
|
#:with τ-tmp (generate-temporary 'τ)
|
|
#:with [e-stx ...] #'[e-stx* ooo ...]
|
|
#:with [e-stx-orig ...] #'[e-stx* ooo ...]
|
|
#:with [e-pat ...]
|
|
#'[(~post
|
|
(~seq
|
|
(~and props.e-pat
|
|
e-pat*)
|
|
ooo ...))]]
|
|
[pattern (~seq [[e-stx* ≫ e-pat*] props:⇐-props] ooo:elipsis ...)
|
|
#:with e-tmp (generate-temporary #'e-pat*)
|
|
#:with τ-tmp (generate-temporary 'τ)
|
|
#:with τ-exp-tmp (generate-temporary 'τ_expected)
|
|
#:with [e-stx ...] #'[(add-expected e-stx* props.τ-stx) ooo ...]
|
|
#:with [e-stx-orig ...] #'[e-stx* ooo ...]
|
|
#:with [e-pat ...]
|
|
#'[(~post
|
|
(~seq
|
|
(~and props.e-pat
|
|
e-pat*)
|
|
ooo ...))]]
|
|
)
|
|
(define-splicing-syntax-class inf*
|
|
[pattern (~seq inf:inf ...)
|
|
#:with [e-stx ...] #'[inf.e-stx ... ...]
|
|
#:with [e-stx-orig ...] #'[inf.e-stx-orig ... ...]
|
|
#:with [e-pat ...] #'[inf.e-pat ... ...]])
|
|
(define-splicing-syntax-class clause
|
|
#:attributes ([pat 1])
|
|
#:datum-literals (⊢ ⇒ ⇐ ≫ τ⊑ :)
|
|
[pattern [⊢ (~and (~seq inf-stuff ...) (~seq inf:inf ...))]
|
|
#:with [:clause] #'[[() () ⊢ inf-stuff ...]]]
|
|
[pattern (~seq [⊢ (~and (~seq inf-stuff ...) (~seq inf:inf ...))] ooo:elipsis)
|
|
#:with [:clause] #'[[() () ⊢ inf-stuff ...] ooo]]
|
|
[pattern (~seq [(tvctx:id-props+≫*) (ctx:id-props+≫*) ⊢ inf:inf*] ooo:elipsis ...)
|
|
#:with tvctxss (cond [(stx-null? #'[tvctx.ctx ...]) #'(in-cycle (in-value '()))]
|
|
[else #'(in-list (syntax->list #'[(tvctx.ctx ...) ooo ...]))])
|
|
#:with ctxss (cond [(stx-null? #'[ctx.ctx ...]) #'(in-cycle (in-value '()))]
|
|
[else #'(in-list (syntax->list #'[(ctx.ctx ...) ooo ...]))])
|
|
#:with [pat ...]
|
|
#'[(~post
|
|
(~post
|
|
(~parse
|
|
[[(tvctx.x- ...) (ctx.x- ...) (inf.e-pat ...) _] ooo ...]
|
|
(for/list ([tvctxs tvctxss]
|
|
[ctxs ctxss]
|
|
[es (in-list (syntax->list #'[(inf.e-stx ...) ooo ...]))]
|
|
[origs (in-list (syntax->list #'[(inf.e-stx-orig ...) ooo ...]))])
|
|
(infer #:tvctx tvctxs #:ctx ctxs (stx-map pass-orig es origs))))))]]
|
|
[pattern [a τ⊑ b]
|
|
#:with [pat ...]
|
|
#'[(~post
|
|
(~fail #:unless (typecheck? #'a #'b)
|
|
(format "type mismatch: expected ~a, given ~a"
|
|
(type->str #'b)
|
|
(type->str #'a))))]]
|
|
[pattern (~seq [a τ⊑ b] ooo:elipsis)
|
|
#:with [pat ...]
|
|
#'[(~post
|
|
(~fail #:unless (typechecks? #'[a ooo] #'[b ooo])
|
|
(format (string-append "type mismatch\n"
|
|
" expected: ~a\n"
|
|
" given: ~a")
|
|
(string-join (stx-map type->str #'[b ooo]) ", ")
|
|
(string-join (stx-map type->str #'[a ooo]) ", "))))]]
|
|
[pattern [#:when condition:expr]
|
|
#:with [pat ...]
|
|
#'[(~fail #:unless condition)]]
|
|
[pattern [#:with pat*:expr expr:expr]
|
|
#:with [pat ...]
|
|
#'[(~post (~parse pat* expr))]]
|
|
[pattern [#:fail-unless condition:expr message:expr]
|
|
#:with [pat ...]
|
|
#'[(~post (~fail #:unless condition message))]]
|
|
)
|
|
(define-syntax-class last-clause
|
|
#:datum-literals (⊢ ≫ ≻ ⇒ ⇐ :)
|
|
#:attributes ([pat 0] [stuff 1])
|
|
[pattern [⊢ [[pat* ≫ e-stx] ⇒ k v]]
|
|
#:with :last-clause #'[⊢ [[pat* ≫ e-stx] (⇒ k v)]]]
|
|
[pattern [⊢ [[pat ≫ e-stx] (⇒ k:id v) ...]]
|
|
#:with [stuff ...]
|
|
#'[(for/fold ([result (quasisyntax/loc this-syntax e-stx)])
|
|
([tag (in-list (list 'k ...))]
|
|
[τ (in-list (list #`v ...))])
|
|
(assign-type result τ #:tag tag))]]
|
|
[pattern [⊢ [[pat* ≫ e-stx] ⇐ : τ-pat]]
|
|
#:with stx (generate-temporary 'stx)
|
|
#:with τ (generate-temporary #'τ-pat)
|
|
#:with pat
|
|
#'(~and stx
|
|
pat*
|
|
(~parse τ (get-expected-type #'stx))
|
|
(~post (~post (~fail #:unless (syntax-e #'τ)
|
|
"no expected type, add annotations")))
|
|
(~parse τ-pat #'τ))
|
|
#:with [stuff ...]
|
|
#'[(assign-type (quasisyntax/loc this-syntax e-stx) #`τ)]]
|
|
[pattern [pat ≻ e-stx]
|
|
#:with [stuff ...]
|
|
#'[(quasisyntax/loc this-syntax e-stx)]]
|
|
[pattern [pat #:error msg:expr]
|
|
#:with [stuff ...]
|
|
#'[#:fail-unless #f msg
|
|
;; should never get here
|
|
(error msg)]])
|
|
(define-splicing-syntax-class pat #:datum-literals (⇐ :)
|
|
[pattern (~seq pat)]
|
|
[pattern (~seq pat* ⇐ : τ-pat)
|
|
#:with stx (generate-temporary 'stx)
|
|
#:with τ (generate-temporary #'τ-pat)
|
|
#:with pat
|
|
#'(~and stx
|
|
pat*
|
|
(~parse τ (get-expected-type #'stx))
|
|
(~post (~post (~fail #:unless (syntax-e #'τ)
|
|
"no expected type, add annotations")))
|
|
(~parse τ-pat #'τ))])
|
|
(define-syntax-class rule #:datum-literals (▶)
|
|
[pattern [pat:pat ▶
|
|
clause:clause ...
|
|
:---
|
|
last-clause:last-clause]
|
|
#:with norm
|
|
#'[(~and pat.pat
|
|
last-clause.pat
|
|
clause.pat ... ...)
|
|
last-clause.stuff ...]])
|
|
)
|
|
(require (for-meta 1 'syntax-classes)
|
|
(for-meta 2 'syntax-classes))
|
|
|
|
(define-syntax define-typed-syntax
|
|
(lambda (stx)
|
|
(syntax-parse stx
|
|
[(def name:id
|
|
(~and (~seq stuff ...) (~or (~seq :keyword _)
|
|
(~seq :keyword)))
|
|
...
|
|
rule:rule
|
|
...)
|
|
#'(-define-typed-syntax
|
|
name
|
|
stuff ... ...
|
|
rule.norm
|
|
...)])))
|
|
|
|
(begin-for-syntax
|
|
(define-syntax syntax-parse/typed-syntax
|
|
(lambda (stx)
|
|
(syntax-parse stx
|
|
[(stxparse
|
|
stx-id:id
|
|
(~and (~seq stuff ...) (~or (~seq :keyword _)
|
|
(~seq :keyword)))
|
|
...
|
|
rule:rule
|
|
...)
|
|
#'(syntax-parse
|
|
stx-id
|
|
stuff ... ...
|
|
rule.norm
|
|
...)]))))
|
|
|