From e6eb482de48b8d82a09a9a18db71a2879a5e620a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 5 Dec 2008 00:25:02 +0000 Subject: [PATCH] Enable require-typed-struct with substructures. Fixes PR 9053. Move test to succeed. Add some new bindings. svn: r12709 --- .../pr9053-fail.ss => succeed/pr9053-2.ss} | 0 collects/typed-scheme/private/base-env.ss | 60 ++++++++++++++++++- collects/typed-scheme/private/parse-type.ss | 5 +- collects/typed-scheme/private/prims.ss | 44 ++++++++++++-- .../typed-scheme/private/type-contract.ss | 14 +++-- .../private/type-effect-convenience.ss | 11 +++- collects/typed-scheme/typecheck/tc-structs.ss | 24 +++++--- .../typed-scheme/typecheck/tc-toplevel.ss | 11 ++++ 8 files changed, 147 insertions(+), 22 deletions(-) rename collects/tests/typed-scheme/{fail/pr9053-fail.ss => succeed/pr9053-2.ss} (100%) diff --git a/collects/tests/typed-scheme/fail/pr9053-fail.ss b/collects/tests/typed-scheme/succeed/pr9053-2.ss similarity index 100% rename from collects/tests/typed-scheme/fail/pr9053-fail.ss rename to collects/tests/typed-scheme/succeed/pr9053-2.ss diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index a71c975708..4ea54fb33e 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -289,6 +289,57 @@ [(-Pattern -InpBts N ?N ) (optlist -Bytes)] [(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))] +[regexp-match* + (let ([?N (-opt N)] + [-StrRx (*Un -String -Regexp -PRegexp)] + [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (*Un -Input-Port -Bytes)]) + (cl->* + (-StrRx -String [N ?N] . ->opt . (-lst -String)) + (-BtsRx -String [N ?N] . ->opt . (-lst -Bytes)) + (-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))] +[regexp-try-match + (let ([?outp (-opt -Output-Port)] + [?N (-opt N)] + [optlist (lambda (t) (-opt (-lst (-opt t))))]) + (->opt -Pattern -Input-Port [N ?N ?outp] (optlist -Bytes)))] + +[regexp-match-exact? + (-Pattern (Un -String -Bytes -Input-Port) . -> . B)] + + +[regexp-match-positions + (let ([?outp (-opt -Output-Port)] + [?N (-opt N)] + [optlist (lambda (t) (-opt (-lst (-opt t))))] + [-StrRx (*Un -String -Regexp -PRegexp)] + [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (*Un -Input-Port -Bytes)]) + (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))] +[regexp-match-positions* + (let ([?outp (-opt -Output-Port)] + [?N (-opt N)] + [optlist (lambda (t) (-opt (-lst (-opt t))))] + [-StrRx (*Un -String -Regexp -PRegexp)] + [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (*Un -Input-Port -Bytes)]) + (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))] +#; +[regexp-match-peek-positions*] +#; +[regexp-split] + +[regexp-quote (cl->* + (->opt -String [Univ] -String) + (->opt -Bytes [Univ] -Bytes))] +[regexp-replace-quote + (cl->* + [-> -String -String] + [-> -Bytes -Bytes])] + + + + [number->string (N . -> . -String)] [current-milliseconds (-> -Integer)] @@ -499,4 +550,11 @@ ;; scheme/bool [boolean=? (B B . -> . B)] [symbol=? (Sym Sym . -> . B)] -[false? (make-pred-ty (-val #f))] \ No newline at end of file +[false? (make-pred-ty (-val #f))] + +;; with-stx.ss +[generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))] +[check-duplicate-identifier ((-lst (-Syntax Sym)) . -> . (-opt (-Syntax Sym)))] + +;; string.ss +[real->decimal-string (N [-Nat] . ->opt . -String)] diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index be6d275263..551dc14b7a 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -26,7 +26,10 @@ (define (parse-type stx) (parameterize ([current-orig-stx stx]) (syntax-case* stx () - symbolic-identifier=? + symbolic-identifier=? + [t + (Type? (syntax-e #'t)) + (syntax-e #'t)] [(fst . rst) (not (syntax->list #'rst)) (-pair (parse-type #'fst) (parse-type #'rst))] diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 719167c8f8..8e4236987f 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -57,6 +57,15 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(_ lib [nm ty] ...) #'(begin (require/typed nm ty lib) ...)] + [(_ nm ty lib #:struct-maker parent) + (with-syntax ([(cnt*) (generate-temporaries #'(nm))]) + (quasisyntax/loc stx (begin + #,(syntax-property (syntax-property #'(define cnt* #f) + 'typechecker:contract-def/maker #'ty) + 'typechecker:ignore #t) + #,(internal #'(require/typed-internal nm ty #:struct-maker parent)) + #,(syntax-property #'(require/contract nm cnt* lib) + 'typechecker:ignore #t))))] [(_ nm ty lib) (identifier? #'nm) (with-syntax ([(cnt*) (generate-temporaries #'(nm))]) @@ -346,9 +355,8 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ nm ([fld : ty] ...) lib) (identifier? #'nm) (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] - [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] - [oty #'(Opaque pred)]) - #'(begin + [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]) + #`(begin (require (only-in lib struct-info)) (define-syntax nm (make-struct-info (lambda () @@ -358,9 +366,33 @@ This file defines two sorts of primitives. All of them are provided into any mod (list #'sel ...) (list mut ...) #f)))) - (require/opaque-type nm pred lib #:name-exists) - (require/typed maker (ty ... -> oty) lib) - (require/typed sel (oty -> ty) lib) ...))])) + #,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) + #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib)) + #,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) + (require/typed maker nm lib #:struct-maker #f) + (require/typed lib + [sel (nm -> ty)]) ...))] + [(_ (nm parent) ([fld : ty] ...) lib) + (and (identifier? #'nm) (identifier? #'parent)) + (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] + [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] + #;[(parent-tys ...) (Struct-flds (parse-type #'parent))]) + #`(begin + (require (only-in lib struct-info)) + (define-syntax nm (make-struct-info + (lambda () + (list #'struct-info + #'maker + #'pred + (list #'sel ...) + (list mut ...) + #f)))) + #,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only)) + #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib)) + #,(internal #'(require/typed-internal pred (Any -> Boolean : nm))) + (require/typed maker nm lib #:struct-maker parent) + (require/typed lib + [sel (nm -> ty)]) ...))])) (define-syntax (do: stx) (syntax-case stx (:) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 2451a9938e..9e1366ab36 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -23,15 +23,21 @@ (for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c))) (define (define/fixup-contract? stx) - (syntax-property stx 'typechecker:contract-def)) + (or (syntax-property stx 'typechecker:contract-def) + (syntax-property stx 'typechecker:contract-def/maker))) (define (generate-contract-def stx) - (define prop (syntax-property stx 'typechecker:contract-def)) + (define prop (or (syntax-property stx 'typechecker:contract-def) + (syntax-property stx 'typechecker:contract-def/maker))) + (define maker? (syntax-property stx 'typechecker:contract-def/maker)) (define typ (parse-type prop)) (syntax-case stx (define-values) [(_ (n) __) - (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) - (syntax/loc stx (define-values (n) cnt)))] + (let ([typ (if maker? + ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ) + typ)]) + (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) + (syntax/loc stx (define-values (n) cnt))))] [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))])) (define (change-contract-fixups forms) diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 217e0c0c7d..b64c391e4f 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -3,6 +3,7 @@ (require (rep type-rep effect-rep) (utils tc-utils) + scheme/list scheme/match "type-comparison.ss" "type-effect-printer.ss" @@ -84,7 +85,7 @@ (define (funty-arities f) (match f [(Function: as) as])) - (make-Function (map car (map funty-arities args)))) + (make-Function (apply append (map funty-arities args)))) (define-syntax (->key stx) (syntax-parse stx @@ -143,6 +144,8 @@ (define Univ (make-Univ)) (define Err (make-Error)) +(define -Nat -Integer) + (define-syntax -v (syntax-rules () [(_ x) (make-F 'x)])) @@ -277,3 +280,9 @@ +(define (opt-fn args opt-args result) + (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))]) + (make-Function (list (make-arr* (append args (take opt-args i)) result)))))) + +(define-syntax-rule (->opt args ... [opt ...] res) + (opt-fn (list args ...) (list opt ...) res)) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 9bd3eca2b0..b95c06da4b 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -91,7 +91,8 @@ #:proc-ty [proc-ty #f] #:maker [maker* #f] #:constructor-return [cret #f] - #:poly? [poly? #f]) + #:poly? [poly? #f] + #:type-only [type-only #f]) ;; create the approriate names that define-struct will bind (define-values (maker pred getters setters) (struct-names nm flds setters?)) (let* ([name (syntax-e nm)] @@ -99,17 +100,19 @@ [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier))] [external-fld-types/no-parent types] [external-fld-types fld-types]) - (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? - #:wrapper wrapper - #:type-wrapper type-wrapper - #:maker (or maker* maker) - #:constructor-return cret))) + (if type-only + (register-type-name nm (wrapper sty)) + (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? + #:wrapper wrapper + #:type-wrapper type-wrapper + #:maker (or maker* maker) + #:constructor-return cret)))) ;; generate names, and register the approriate types give field types and structure type ;; optionally wrap things ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? - #:wrapper [wrapper (lambda (x) x)] + #:wrapper [wrapper values] #:type-wrapper [type-wrapper values] #:maker [maker* #f] #:constructor-return [cret #f]) @@ -168,7 +171,9 @@ ;; typecheck a non-polymophic struct and register the approriate types ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void -(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]) +(define (tc/struct nm/par flds tys [proc-ty #f] + #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f] + #:type-only [type-only #f]) ;; get the parent info and create some types and type variables (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) ;; parse the field types, and determine if the type is recursive @@ -184,7 +189,8 @@ #:proc-ty proc-ty-parsed #:maker maker #:constructor-return (and cret (parse-type cret)) - #:mutable mutable)) + #:mutable mutable + #:type-only type-only)) ;; register a struct type ;; convenience function for built-in structs diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 2c3aa72e28..f0553c1e21 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -7,6 +7,7 @@ scheme/match "signatures.ss" "tc-structs.ss" + (rep type-rep) (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract) (env type-env init-envs type-name-env type-alias-env) (utils tc-utils) @@ -44,6 +45,13 @@ (register-type #'nm t) (list (make-def-binding #'nm t)))] + [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values))) + (let* ([t (parse-type #'ty)] + [flds (Struct-flds (lookup-type-name (Name-id t)))] + [mk-ty (flds #f . ->* . t)]) + (register-type #'nm mk-ty) + (list (make-def-binding #'nm mk-ty)))] + ;; define-typed-struct [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] @@ -52,6 +60,9 @@ [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t)) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) + (#%plain-app values))) + (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)] ;; define-typed-struct w/ polymorphism [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values))) (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]