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

set up some information for TR

Browse Source
This commit is contained in:
Robby Findler 2015-12-05 15:35:07 -06:00
parent d87e3ead7f
commit 8b3369f81c
4 changed files with 50 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
racket/collects/racket/contract/private/guts.rkt
View File

@ -38,6 +38,7 @@
;; helpers for adding properties that check syntax uses
define/final-prop
define/subexpression-pos-prop
define/subexpression-pos-prop/name
make-predicate-contract
@ -332,6 +333,42 @@
(list (car (syntax-e stx)))
'())))])))))]))
(define-syntax (define/subexpression-pos-prop/name stx)
(syntax-case stx ()
[(_ ctc/proc header bodies ...)
(with-syntax ([ctc (if (identifier? #'header)
#'header
(car (syntax-e #'header)))])
#'(begin
(define ctc/proc
(let ()
(define header bodies ...)
ctc))
(define-syntax (ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
#'ctc/proc
'racket/contract:contract
(vector (gensym 'ctc)
(list stx)
'()))]
[(_ margs (... ...))
(let ([this-one (gensym 'ctc)])
(with-syntax ([(margs (... ...))
(map (λ (x) (syntax-property x
'racket/contract:positive-position
this-one))
(syntax->list #'(margs (... ...))))]
[app (datum->syntax stx '#%app)])
(syntax-property
#'(app ctc/proc margs (... ...))
'racket/contract:contract
(vector this-one
(list (car (syntax-e stx)))
'()))))]))))]))
(define-syntax (define/subexpression-pos-prop stx)
(syntax-case stx ()
[(_ header bodies ...)
@ -339,35 +376,7 @@
#'header
(car (syntax-e #'header)))])
(with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))])
#'(begin
(define ctc/proc
(let ()
(define header bodies ...)
ctc))
(define-syntax (ctc stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
#'ctc/proc
'racket/contract:contract
(vector (gensym 'ctc)
(list stx)
'()))]
[(_ margs (... ...))
(let ([this-one (gensym 'ctc)])
(with-syntax ([(margs (... ...))
(map (λ (x) (syntax-property x
'racket/contract:positive-position
this-one))
(syntax->list #'(margs (... ...))))]
[app (datum->syntax stx '#%app)])
(syntax-property
#'(app ctc/proc margs (... ...))
'racket/contract:contract
(vector this-one
(list (car (syntax-e stx)))
'()))))])))))]))
#'(define/subexpression-pos-prop/name ctc/proc header bodies ...)))]))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)

2
racket/collects/racket/contract/private/misc.rkt
View File

@ -307,7 +307,7 @@
(identifier? #'x)
#'real-and/c]))
(define/subexpression-pos-prop (real-and/c . raw-fs)
(define/subexpression-pos-prop/name real-and/c-name (real-and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
(cond
[(null? contracts) any/c]

2
racket/collects/racket/contract/private/orc.rkt
View File

@ -12,7 +12,7 @@
blame-add-ior-context
(rename-out [_flat-rec-contract flat-rec-contract]))
(define/subexpression-pos-prop or/c
(define/subexpression-pos-prop/name or/c-name or/c
(case-lambda
[() (make-none/c '(or/c))]
[(x) (coerce-contract 'or/c x)]

10
racket/collects/racket/contract/private/types.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang racket/base
(provide types)
(define types
(hash '(real-and/c-name racket/contract/private/misc)
'(->* () #:rest Contract Contract)
'(or/c-name racket/contract/private/orc)
'(->* () #:rest Contract Contract)))
;; cast : alpha (<alpha,beta> ctc) -> beta