Remove macro-debugger require.
Use `this-syntax' More contract renamers Finish type-abbrev.ss svn: r13785
This commit is contained in:
Sam Tobin-Hochstadt
parent
a1fb696233
commit
0343ae06f3
|
|
@ -2,113 +2,66 @@
|
|||
|
||||
(require "../utils/utils.ss")
|
||||
|
||||
(require (rep type-rep effect-rep)
|
||||
(require (rep type-rep object-rep filter-rep printer)
|
||||
(utils tc-utils)
|
||||
scheme/list
|
||||
scheme/match
|
||||
"type-effect-printer.ss"
|
||||
scheme/match
|
||||
scheme/promise
|
||||
(prefix-in c: scheme/contract)
|
||||
(for-syntax scheme/base stxclass)
|
||||
(for-template scheme/base scheme/contract scheme/tcp))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define top-func (make-Function (list (make-top-arr))))
|
||||
;; convenient constructors
|
||||
|
||||
(define (-vet id) (make-Var-True-Effect id))
|
||||
(define (-vef id) (make-Var-False-Effect id))
|
||||
(define -values make-Values)
|
||||
(define -pair make-Pair)
|
||||
(define -struct make-Struct)
|
||||
(define -val make-Value)
|
||||
(define -lst make-Listof)
|
||||
(define -Param make-Param)
|
||||
(define -box make-Box)
|
||||
(define -vec make-Vector)
|
||||
(define -LFS make-LFilterSet)
|
||||
|
||||
(define -rem make-Remove-Effect)
|
||||
(define -rest make-Restrict-Effect)
|
||||
(define-syntax *Un
|
||||
(syntax-rules ()
|
||||
[(_ . args) (make-Union (list . args))]))
|
||||
|
||||
(define (var->type-eff eff)
|
||||
(match eff
|
||||
[(Var-True-Effect: v) (make-Remove-Effect (make-Value #f) v)]
|
||||
[(Var-False-Effect: v) (make-Restrict-Effect (make-Value #f) v)]
|
||||
[_ eff]))
|
||||
|
||||
(define ((add-var v) eff)
|
||||
(match eff
|
||||
[(Latent-Var-True-Effect:) (-vet v)]
|
||||
[(Latent-Var-False-Effect:) (-vef v)]
|
||||
[(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)]
|
||||
[(Latent-Remove-Effect: t) (make-Remove-Effect t v)]
|
||||
[(True-Effect:) eff]
|
||||
[(False-Effect:) eff]
|
||||
[_ (int-err "can't add var ~a to effect ~a" v eff)]))
|
||||
(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
|
||||
|
||||
(define-syntax (-> stx)
|
||||
(syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
||||
[(_ dom ... rng : eff1 eff2)
|
||||
#'(->* (list dom ...) rng : eff1 eff2)]
|
||||
[(_ dom ... rng : eff1 eff2)
|
||||
#'(->* (list dom ...) rng : eff1 eff2)]
|
||||
[(_ dom ... rng)
|
||||
#'(->* (list dom ...) rng)]))
|
||||
(define (-lst* #:tail [tail (-val null)] . args)
|
||||
(if (null? args)
|
||||
tail
|
||||
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
|
||||
|
||||
(define-syntax ->*
|
||||
(syntax-rules (:)
|
||||
[(_ dom rng)
|
||||
(make-Function (list (make-arr* dom rng)))]
|
||||
[(_ dom rst rng)
|
||||
(make-Function (list (make-arr* dom rng rst)))]
|
||||
[(_ dom rng : eff1 eff2)
|
||||
(make-Function (list (make-arr* dom rng #f eff1 eff2)))]
|
||||
[(_ dom rst rng : eff1 eff2)
|
||||
(make-Function (list (make-arr* dom rng rst eff1 eff2)))]))
|
||||
(define-syntax ->...
|
||||
(syntax-rules (:)
|
||||
[(_ dom rng)
|
||||
(->* dom rng)]
|
||||
[(_ dom (dty dbound) rng)
|
||||
(make-Function (list (make-arr* dom rng #f (cons dty 'dbound) (list) (list))))]
|
||||
[(_ dom rng : eff1 eff2)
|
||||
(->* dom rng : eff1 eff2)]
|
||||
[(_ dom (dty dbound) rng : eff1 eff2)
|
||||
(make-Function (list (make-arr* dom rng #f (cons dty 'dbound) eff1 eff2)))]))
|
||||
(define-syntax cl->
|
||||
(syntax-rules (:)
|
||||
[(_ [(dom ...) rng] ...)
|
||||
(make-Function (list (make-arr* (list dom ...) rng) ...))]
|
||||
[(_ [(dom ...) rng : eff1 eff2] ...)
|
||||
(make-Function (list (make-arr* (list dom ...) rng #f eff1 eff2) ...))]
|
||||
[(_ [(dom ...) rng rst : eff1 eff2] ...)
|
||||
(make-Function (list (make-arr* (list dom ...) rng rst eff1 eff2) ...))]))
|
||||
(define (cl->* . args)
|
||||
(define (funty-arities f)
|
||||
(match f
|
||||
[(Function: as) as]))
|
||||
(make-Function (apply append (map funty-arities args))))
|
||||
(define (-Tuple l)
|
||||
(foldr -pair (-val '()) l))
|
||||
|
||||
(define-syntax (->key stx)
|
||||
(syntax-parse stx
|
||||
[(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
|
||||
#'(make-Function
|
||||
(list
|
||||
(make-arr* (list ty ...)
|
||||
rng
|
||||
#f
|
||||
#f
|
||||
(list (make-Keyword 'k kty opt) ...)
|
||||
null
|
||||
null)))]))
|
||||
(define (untuple t)
|
||||
(match t
|
||||
[(Value: '()) null]
|
||||
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
|
||||
[else #f])]
|
||||
[_ #f]))
|
||||
|
||||
(define make-arr*
|
||||
(case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))]
|
||||
[(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
|
||||
[(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
|
||||
[(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]
|
||||
[(dom rng rest drest kws eff1 eff2)
|
||||
(make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword<?) eff1 eff2)]))
|
||||
|
||||
(define (make-arr-dots dom rng dty dbound)
|
||||
(make-arr* dom rng #f (cons dty dbound) null null))
|
||||
(d/c (-result t [f -no-lfilter] [o -no-lobj])
|
||||
(c:->* (Type/c) (LFilterSet? LatentObject?) Result?)
|
||||
(make-Result t f o))
|
||||
|
||||
;; basic types
|
||||
|
||||
(define make-promise-ty
|
||||
(let ([s (string->uninterned-symbol "Promise")])
|
||||
(lambda (t)
|
||||
(make-Struct s #f (list t) #f #f #'promise? values))))
|
||||
|
||||
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
|
||||
|
||||
|
||||
(define N (make-Base 'Number #'number?))
|
||||
(define -Integer (make-Base 'Integer #'exact-integer?))
|
||||
(define B (make-Base 'Boolean #'boolean?))
|
||||
|
|
@ -139,6 +92,35 @@
|
|||
|
||||
(define -Nat -Integer)
|
||||
|
||||
(define Any-Syntax
|
||||
(-mu x
|
||||
(-Syntax (*Un
|
||||
N
|
||||
B
|
||||
Sym
|
||||
-String
|
||||
-Keyword
|
||||
(-mu y (*Un (-val '()) (-pair x (*Un x y))))
|
||||
(make-Vector x)
|
||||
(make-Box x)))))
|
||||
|
||||
(define Ident (-Syntax Sym))
|
||||
|
||||
(define -Sexp (-mu x (*Un (-val null) N B Sym -String (-pair x x))))
|
||||
(define -Port (*Un -Output-Port -Input-Port))
|
||||
|
||||
(define -Pathlike (*Un -String -Path))
|
||||
(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same)))
|
||||
(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String))
|
||||
(define -Byte N)
|
||||
|
||||
(define -no-lfilter (make-LFilterSet null null))
|
||||
(define -no-filter (make-FilterSet null null))
|
||||
(define -no-lobj (make-LEmpty))
|
||||
(define -no-obj (make-Empty))
|
||||
|
||||
;; convenient syntax
|
||||
|
||||
(define-syntax -v
|
||||
(syntax-rules ()
|
||||
[(_ x) (make-F 'x)]))
|
||||
|
|
@ -162,71 +144,76 @@
|
|||
(let ([var (-v var)])
|
||||
(make-Mu 'var ty))]))
|
||||
|
||||
;; function type constructors
|
||||
|
||||
(define -values make-Values)
|
||||
(define top-func (make-Function (list (make-top-arr))))
|
||||
|
||||
(define-syntax *Un
|
||||
(syntax-rules ()
|
||||
[(_ . args) (make-Union (list . args))]))
|
||||
(d/c (make-arr* dom rng
|
||||
#:rest [rest #f] #:drest [drest #f] #:kws [kws null]
|
||||
#:filters [filters -no-lfilter] #:object [obj -no-lobj])
|
||||
(c:->* ((listof Type/c) Type/c)
|
||||
(#:rest Type/c
|
||||
#:drest (cons/c symbol? Type/c)
|
||||
#:kws (listof Keyword?)
|
||||
#:filters LFilterSet?
|
||||
#:object LatentObject?)
|
||||
arr?)
|
||||
(make-arr dom (-result rng filters obj) rest drest (sort #:key Keyword-kw kws keyword<?)))
|
||||
|
||||
(define-syntax ->*
|
||||
(syntax-rules (:)
|
||||
[(_ dom rng)
|
||||
(make-Function (list (make-arr* dom rng)))]
|
||||
[(_ dom rst rng)
|
||||
(make-Function (list (make-arr* dom rng #:rest rst)))]
|
||||
[(_ dom rng : filters)
|
||||
(make-Function (list (make-arr* dom rng #f #:filters filters)))]
|
||||
[(_ dom rst rng : filters)
|
||||
(make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))]))
|
||||
|
||||
(define -pair make-Pair)
|
||||
(define-syntax (-> stx)
|
||||
(syntax-parse stx
|
||||
#:literals (:)
|
||||
[(_ dom ... rng : filters)
|
||||
#'(->* (list dom ...) rng : filters)]
|
||||
[(_ dom ... rng : filters)
|
||||
#'(->* (list dom ...) rng : filters)]
|
||||
[(_ dom ... rng)
|
||||
#'(->* (list dom ...) rng)]))
|
||||
|
||||
(define -struct make-Struct)
|
||||
(define -val make-Value)
|
||||
(define-syntax ->...
|
||||
(syntax-rules (:)
|
||||
[(_ dom rng)
|
||||
(->* dom rng)]
|
||||
[(_ dom (dty dbound) rng)
|
||||
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound))))]
|
||||
[(_ dom rng : filters)
|
||||
(->* dom rng : filters)]
|
||||
[(_ dom (dty dbound) rng : filters)
|
||||
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))]))
|
||||
|
||||
(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
|
||||
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
|
||||
(define (cl->* . args)
|
||||
(define (funty-arities f)
|
||||
(match f
|
||||
[(Function: as) as]))
|
||||
(make-Function (apply append (map funty-arities args))))
|
||||
|
||||
(define -lst make-Listof)
|
||||
(define -Sexp (-mu x (*Un N B Sym -String (-val null) (-pair x x))))
|
||||
(define -Port (*Un -Output-Port -Input-Port))
|
||||
(define-syntax (->key stx)
|
||||
(syntax-parse stx
|
||||
[(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
|
||||
#'(make-Function
|
||||
(list
|
||||
(make-arr* (list ty ...)
|
||||
rng
|
||||
#:kws (list (make-Keyword 'k kty opt) ...))))]))
|
||||
|
||||
(define (-lst* #:tail [tail (-val null)] . args)
|
||||
(if (null? args)
|
||||
tail
|
||||
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
|
||||
(define (make-arr-dots dom rng dty dbound)
|
||||
(make-arr* dom rng #:drest (cons dty dbound)))
|
||||
|
||||
|
||||
#;(define NE (-mu x (Un N (make-Listof x))))
|
||||
(define -NE (-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null)))))))
|
||||
|
||||
(define -Param make-Param)
|
||||
|
||||
(define make-pred-ty
|
||||
(case-lambda
|
||||
[(in out t)
|
||||
(->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))]
|
||||
(->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))]
|
||||
[(t) (make-pred-ty (list Univ) B t)]))
|
||||
|
||||
(define -Pathlike (*Un -String -Path))
|
||||
(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same)))
|
||||
(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String))
|
||||
(define -Byte N)
|
||||
|
||||
(define (-Tuple l)
|
||||
(foldr -pair (-val '()) l))
|
||||
|
||||
(define (untuple t)
|
||||
(match t
|
||||
[(Value: '()) null]
|
||||
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
|
||||
[else #f])]
|
||||
[_ #f]))
|
||||
|
||||
(define -box make-Box)
|
||||
(define -vec make-Vector)
|
||||
|
||||
(define Any-Syntax ;(-Syntax Univ)
|
||||
(-mu x
|
||||
(-Syntax (*Un
|
||||
N
|
||||
B
|
||||
Sym
|
||||
-String
|
||||
-Keyword
|
||||
(-mu y (*Un (-val '()) (-pair x (*Un x y))))
|
||||
(make-Vector x)
|
||||
(make-Box x)))))
|
||||
|
||||
(define Ident (-Syntax Sym))
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/boundmap (for-syntax scheme/base stxclass)
|
||||
macro-debugger/stepper)
|
||||
#;macro-debugger/stepper)
|
||||
|
||||
(provide defintern hash-id)
|
||||
|
||||
|
|
|
|||
|
|
@ -170,16 +170,16 @@
|
|||
(k:keyword #:matcher mtch pats ... e:expr)
|
||||
#:with kw #'k.datum
|
||||
#:with val (list #'mtch
|
||||
(syntax #;#;/loc (current-syntax-context) (pats ...))
|
||||
(syntax/loc this-syntax (pats ...))
|
||||
(lambda () #'e)
|
||||
#'here #;(current-syntax-context)))
|
||||
this-syntax))
|
||||
(pattern
|
||||
(k:keyword pats ... e:expr)
|
||||
#:with kw (syntax-e #'k)
|
||||
#:with val (list (mk-matcher #'kw)
|
||||
(syntax #;#;/loc (current-syntax-context) (pats ...))
|
||||
(syntax/loc this-syntax (pats ...))
|
||||
(lambda () #'e)
|
||||
#'here #;(current-syntax-context))))
|
||||
this-syntax)))
|
||||
(define (gen-clause k v)
|
||||
(match v
|
||||
[(list match-ex pats body-f src)
|
||||
|
|
@ -210,12 +210,7 @@
|
|||
(for/list ([rec-id rec-ids]
|
||||
[k kws])
|
||||
#`[#,rec-id #,(hash-ref (attribute recs.mapping) k
|
||||
#'values
|
||||
#;
|
||||
(lambda ()
|
||||
(error (format
|
||||
"failed to find key ~a in table ~a"
|
||||
k (attribute recs.mapping)))))])])
|
||||
#'values)])])
|
||||
#`(let (let-clauses ...
|
||||
[#,fold-target ty])
|
||||
;; then generate the fold
|
||||
|
|
|
|||
|
|
@ -164,7 +164,7 @@
|
|||
[(_ val)
|
||||
#'(? (lambda (x) (equal? val x)))])))
|
||||
|
||||
(define-for-syntax printing? #t)
|
||||
(define-for-syntax printing? #f)
|
||||
|
||||
(define-syntax-rule (defprinter t ...)
|
||||
(begin
|
||||
|
|
@ -241,7 +241,7 @@
|
|||
(append t (build-list (- (length s) (length t)) (lambda _ extra))))
|
||||
|
||||
(define-for-syntax enable-contracts? #t)
|
||||
(provide (for-syntax enable-contracts?) p/c w/c cnt)
|
||||
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
|
||||
|
||||
(define-syntax p/c
|
||||
(if enable-contracts?
|
||||
|
|
@ -265,6 +265,21 @@
|
|||
[(_ name specs . body)
|
||||
#'(begin . body)]))))
|
||||
|
||||
(define-syntax d/c
|
||||
(if enable-contracts?
|
||||
(make-rename-transformer #'define/contract)
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ head cnt . body)
|
||||
#'(define head . body)]))))
|
||||
|
||||
(define-syntax d-s/c
|
||||
(if enable-contracts?
|
||||
(make-rename-transformer #'define-struct/contract)
|
||||
(syntax-rules ()
|
||||
[(_ hd ([i c] ...) . opts)
|
||||
(define-struct hd (i ...) . opts)])))
|
||||
|
||||
(define-signature-form (cnt stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nm cnt)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user