Initial implementation of struct-type contract generation.
Currently errors on all reflective access to struct types. original commit: d3167c1ce4250b82991ec3984e9245300f8020ce
This commit is contained in:
Sam Tobin-Hochstadt
parent
6a7ff0c342
commit
2c836801af
|
|
@ -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))]
|
||||
|
|
|
|||
|
|
@ -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?))
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue
Block a user