From 2c836801afc55b3515930e59e6d51dbb23772c67 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 10 Jul 2014 15:28:45 -0400 Subject: [PATCH] Initial implementation of struct-type contract generation. Currently errors on all reflective access to struct types. original commit: d3167c1ce4250b82991ec3984e9245300f8020ce --- .../typed-racket/private/type-contract.rkt | 6 +++ .../static-contracts/combinators/derived.rkt | 2 + .../static-contracts/combinators/struct.rkt | 40 +++++++++++++++++-- .../static-contracts/structures.rkt | 10 ++--- .../typed-racket/typed-racket.rkt | 2 +- .../typed-racket/utils/struct-type-c.rkt | 40 +++++++++++++++++++ .../succeed/struct-type-contract.rkt | 12 ++++++ 7 files changed, 103 insertions(+), 9 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/struct-type-c.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/struct-type-contract.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index 1f92c6e5..91e88330 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -332,6 +332,7 @@ [(Prompt-TagTop:) (only-untyped prompt-tag?/sc)] [(Continuation-Mark-KeyTop:) (only-untyped continuation-mark-key?/sc)] [(ClassTop:) (only-untyped class?/sc)] + [(StructTypeTop:) (struct-type/sc null)] ;; TODO Figure out how this should work ;[(StructTop: s) (struct-top/sc s)] @@ -451,6 +452,11 @@ (recursive-sc (list nm*) (list (struct/sc nm (ormap values mut?) fields)) (recursive-sc-use nm*))] [else (flat/sc #`(flat-named-contract '#,(syntax-e pred?) (lambda (x) (#,pred? x))))])] + [(StructType: s) + (if (from-untyped? typed-side) + (fail #:reason (~a "cannot import structure types from" + "untyped code")) + (struct-type/sc null))] [(Syntax: (Base: 'Symbol _ _ _)) identifier?/sc] [(Syntax: t) (syntax/sc (t->sc t))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt index 8ca3e973..f41db047 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/derived.rkt @@ -34,3 +34,5 @@ (define continuation-mark-key?/sc (flat/sc #'continuation-mark-key?)) (define class?/sc (flat/sc #'class?)) + +(define struct-type?/sc (flat/sc #'struct-type?)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt index 4d73706e..985cc6d2 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt @@ -6,13 +6,19 @@ racket/list racket/match unstable/contract racket/contract - (for-template racket/base racket/contract/base) + (for-template racket/base racket/contract/base "../../utils/struct-type-c.rkt") (for-syntax racket/base syntax/parse)) + + (provide (contract-out - [struct/sc (identifier? boolean? (listof static-contract?) . -> . static-contract?)]) - struct/sc:) + [struct/sc (identifier? boolean? (listof static-contract?) . -> . static-contract?)] + ;; #f as argument indicates StructTypeTop, which should fail on + ;; all reflective operations. + [struct-type/sc (any/c . -> . static-contract?)]) + struct/sc: + struct-type/sc:) (struct struct-combinator combinator (name mut?) @@ -47,3 +53,31 @@ (syntax-parser [(_ name fields) #'(struct-combinator fields name _)])) + +;; FIXME: Currently ignores the structure type and fails on all +;; reflective use. +(struct struct-type/sc combinator () + #:transparent + #:property prop:combinator-name "struct-type/sc" + #:methods gen:sc + [(define (sc-map v f) + (match v + [(struct-type/sc args) + (struct-type/sc (map (λ (a) (f a 'covariant)) args))])) + (define (sc-traverse v f) + (match v + [(struct-type/sc args) + (for-each (λ (a) (f a 'covariant)) args) + (void)])) + (define (sc->contract v f) + (match v + [(struct-type/sc args) + #`(struct-type/c #f)])) + (define (sc->constraints v f) + (match v + [(struct-type/sc args) (simple-contract-restrict 'chaperone)]))]) + +(define-match-expander struct-type/sc: + (syntax-parser + [(_ args) + #'(struct-type/sc args)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt index 74d3baf4..549605b9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/structures.rkt @@ -14,14 +14,14 @@ (struct recursive-sc-use ([name identifier?])) (struct combinator ([args sequence?])) (struct static-contract ()) - [sc-map (static-contract? (static-contract? variance/c . -> . static-contract?) . -> . static-contract?)] + [sc-map + (static-contract? (static-contract? variance/c . -> . static-contract?) . -> . static-contract?)] [sc-traverse (static-contract? (static-contract? variance/c . -> . any/c) . -> . void?)] [sc->contract (static-contract? (static-contract? . -> . syntax?) . -> . syntax?)] - [sc->constraints (static-contract? (static-contract? . -> . contract-restrict?) . -> . contract-restrict?)] + [sc->constraints + (static-contract? (static-contract? . -> . contract-restrict?) . -> . contract-restrict?)] [sc-terminal-kind (static-contract? . -> . (or/c #f contract-kind?))] - [sc? predicate/c] - ) - + [sc? predicate/c]) prop:combinator-name gen:sc) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt index 497d8590..0f26589f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typed-racket.rkt @@ -10,7 +10,7 @@ (submod "private/type-contract.rkt" predicates) "utils/utils.rkt" (for-syntax "utils/utils.rkt") - "utils/any-wrap.rkt" unstable/contract racket/contract/parametric) + "utils/any-wrap.rkt" "utils/struct-type-c.rkt" unstable/contract racket/contract/parametric) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/struct-type-c.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/struct-type-c.rkt new file mode 100644 index 00000000..99d4d59d --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/struct-type-c.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(provide struct-type/c) +(require racket/contract/base racket/contract/combinator) + +;; struct-type/c generates contracts which protect structure type +;; descriptors. These descriptors can be used reflectively to create +;; constructors, accessors, mutators, predicates, and other +;; structure-related functions. + +;; Currently, this is a very simple implentation which always rejects +;; all reflective access. A better implementation would check that the +;; procedures created by reflective access to the structure obey +;; appropriate invariants. + +(define (val-first-projection b) + (define (fail neg-party v) + (raise-blame-error + (blame-swap b) #:missing-party neg-party + v + "Attempted to use a struct type reflectively in untyped code: ~v" v)) + (λ (v) + (λ (neg-party) + (chaperone-struct-type + v + ;; the below interposition functions could be improved to fail later, + ;; when the functions they produce are actually used. + + ;; interposition for `struct-type-info` + (λ _ (fail neg-party v)) + ;; interposition for `struct-type-make-constructor` + (λ _ (fail neg-party v)) + ;; guard for interposition on subtypes + (λ _ (fail neg-party v)))))) + +(define (struct-type/c sty) ;; currently ignores sty + (make-chaperone-contract + #:name "struct-type/c" + #:first-order struct-type? + #:projection (λ (blame) (λ (val) (((val-first-projection blame) val) #f))) + #:val-first-projection val-first-projection)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/struct-type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/struct-type-contract.rkt new file mode 100644 index 00000000..4f984d7b --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/struct-type-contract.rkt @@ -0,0 +1,12 @@ +#lang racket/load + +(module m1 typed/racket + (struct x ()) + (define: y : Struct-TypeTop struct:x) + (provide struct:x y)) + +(module m2 racket + (require 'm1) + struct:x y) + +(require 'm2)