Refactoring all the private contract stuff into its own playpen.
svn: r16052
This commit is contained in:
Stevie Strickland
parent
3805186531
commit
636adcc142
|
|
@ -29,22 +29,22 @@
|
|||
;; except the arrow contracts
|
||||
;;
|
||||
|
||||
(require scheme/private/contract-base
|
||||
scheme/private/contract-misc
|
||||
scheme/private/contract-provide
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-opt
|
||||
scheme/private/contract-basic-opters)
|
||||
(require scheme/contract/private/base
|
||||
scheme/contract/private/misc
|
||||
scheme/contract/private/provide
|
||||
scheme/contract/private/guts
|
||||
scheme/contract/private/ds
|
||||
scheme/contract/private/opt
|
||||
scheme/contract/private/basic-opters)
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
|
||||
(except-out (all-from-out scheme/private/contract-ds)
|
||||
(except-out (all-from-out scheme/contract/private/ds)
|
||||
lazy-depth-to-look)
|
||||
|
||||
(all-from-out scheme/private/contract-base)
|
||||
(all-from-out scheme/private/contract-provide)
|
||||
(except-out (all-from-out scheme/private/contract-misc)
|
||||
(all-from-out scheme/contract/private/base)
|
||||
(all-from-out scheme/contract/private/provide)
|
||||
(except-out (all-from-out scheme/contract/private/misc)
|
||||
check-between/c
|
||||
string-len/c
|
||||
check-unary-between/c)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
(require scheme/private/contract-guts)
|
||||
(require scheme/contract/private/guts)
|
||||
|
||||
(define empty-case-lambda/c
|
||||
(flat-named-contract '(case->)
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-template scheme/base)
|
||||
(for-template scheme/private/contract-guts)
|
||||
(for-template scheme/contract/private/guts)
|
||||
(for-template "contract-arr-checks.ss"))
|
||||
|
||||
(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/private/contract-guts
|
||||
scheme/private/contract-opt
|
||||
(require scheme/contract/private/guts
|
||||
scheme/contract/private/opt
|
||||
"contract-arr-checks.ss")
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax scheme/private/contract-opt-guts)
|
||||
(for-syntax scheme/private/contract-helpers)
|
||||
(for-syntax scheme/contract/private/opt-guts)
|
||||
(for-syntax scheme/contract/private/helpers)
|
||||
(for-syntax "contract-arr-obj-helpers.ss")
|
||||
(for-syntax syntax/stx)
|
||||
(for-syntax syntax/name))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(require (for-syntax scheme/base)
|
||||
(only-in scheme/contract contract)
|
||||
(for-syntax (prefix-in a: scheme/private/contract-helpers)))
|
||||
(for-syntax (prefix-in a: scheme/contract/private/helpers)))
|
||||
|
||||
;; First, we have the old define/contract implementation, which
|
||||
;; is still used in mzlib/contract.
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
(require "contract-arrow.ss"
|
||||
scheme/private/contract-guts
|
||||
scheme/contract/private/guts
|
||||
scheme/private/class-internal
|
||||
"contract-arr-checks.ss")
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/private/contract-helpers
|
||||
scheme/contract/private/helpers
|
||||
"contract-arr-obj-helpers.ss"))
|
||||
|
||||
(provide mixin-contract
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(module class mzscheme
|
||||
|
||||
(require "private/contract-object.ss")
|
||||
(provide (all-from "private/contract-object.ss"))
|
||||
(require "contract/private/object.ss")
|
||||
(provide (all-from "contract/private/object.ss"))
|
||||
|
||||
;; All of the implementation is actually in private/class-internal.ss,
|
||||
;; which provides extra (private) functionality to contract.ss.
|
||||
|
|
|
|||
|
|
@ -9,34 +9,34 @@ differences from v3:
|
|||
|
||||
|#
|
||||
|
||||
(require "private/contract-arrow.ss"
|
||||
"private/contract-base.ss"
|
||||
"private/contract-exists.ss"
|
||||
"private/contract-misc.ss"
|
||||
"private/contract-provide.ss"
|
||||
"private/contract-regions.ss"
|
||||
"private/contract-guts.ss"
|
||||
"private/contract-ds.ss"
|
||||
"private/contract-opt.ss"
|
||||
"private/contract-basic-opters.ss")
|
||||
(require "contract/private/arrow.ss"
|
||||
"contract/private/base.ss"
|
||||
scheme/contract/exists
|
||||
"contract/private/misc.ss"
|
||||
"contract/private/provide.ss"
|
||||
scheme/contract/regions
|
||||
"contract/private/guts.ss"
|
||||
"contract/private/ds.ss"
|
||||
"contract/private/opt.ss"
|
||||
"contract/private/basic-opters.ss")
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from-out "private/contract-opt.ss")
|
||||
(except-out (all-from-out "private/contract-ds.ss")
|
||||
opt/c define-opt/c ;(all-from-out "contract/private/opt.ss")
|
||||
(except-out (all-from-out "contract/private/ds.ss")
|
||||
lazy-depth-to-look)
|
||||
|
||||
(except-out (all-from-out "private/contract-arrow.ss")
|
||||
(except-out (all-from-out "contract/private/arrow.ss")
|
||||
making-a-method
|
||||
procedure-accepts-and-more?
|
||||
check-procedure
|
||||
check-procedure/more)
|
||||
(except-out (all-from-out "private/contract-exists.ss") ∃?)
|
||||
(except-out (all-from-out "private/contract-misc.ss")
|
||||
(except-out (all-from-out scheme/contract/exists) ∃?)
|
||||
(except-out (all-from-out "contract/private/misc.ss")
|
||||
check-between/c
|
||||
check-unary-between/c)
|
||||
(all-from-out "private/contract-regions.ss")
|
||||
(all-from-out "private/contract-provide.ss")
|
||||
(all-from-out "private/contract-base.ss"))
|
||||
(all-from-out scheme/contract/regions)
|
||||
(all-from-out "contract/private/provide.ss")
|
||||
(all-from-out "contract/private/base.ss"))
|
||||
|
||||
;; from contract-guts.ss
|
||||
|
||||
|
|
|
|||
|
|
@ -3,31 +3,31 @@
|
|||
;; A stripped down version of scheme/contract for use in
|
||||
;; the PLT code base where appropriate.
|
||||
|
||||
(require scheme/private/contract-arrow
|
||||
scheme/private/contract-base
|
||||
scheme/private/contract-misc
|
||||
scheme/private/contract-provide
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-opt)
|
||||
(require "private/arrow.ss"
|
||||
"private/base.ss"
|
||||
"private/misc.ss"
|
||||
"private/provide.ss"
|
||||
"private/guts.ss"
|
||||
"private/ds.ss"
|
||||
"private/opt.ss")
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from-out "private/contract-opt.ss")
|
||||
(except-out (all-from-out scheme/private/contract-ds)
|
||||
opt/c define-opt/c ;(all-from-out "private/opt.ss")
|
||||
(except-out (all-from-out "private/ds.ss")
|
||||
lazy-depth-to-look)
|
||||
|
||||
(except-out (all-from-out scheme/private/contract-arrow)
|
||||
(except-out (all-from-out "private/arrow.ss")
|
||||
making-a-method
|
||||
procedure-accepts-and-more?
|
||||
check-procedure
|
||||
check-procedure/more)
|
||||
(except-out (all-from-out scheme/private/contract-misc)
|
||||
(except-out (all-from-out "private/misc.ss")
|
||||
check-between/c
|
||||
check-unary-between/c)
|
||||
(all-from-out scheme/private/contract-provide)
|
||||
(all-from-out scheme/private/contract-base))
|
||||
(all-from-out "private/provide.ss")
|
||||
(all-from-out "private/base.ss"))
|
||||
|
||||
;; from contract-guts.ss
|
||||
;; from private/guts.ss
|
||||
|
||||
(provide any
|
||||
and/c
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "contract-guts.ss")
|
||||
(require "private/guts.ss")
|
||||
|
||||
(provide new-∃/c
|
||||
∃?)
|
||||
|
|
@ -18,12 +18,12 @@ v4 todo:
|
|||
|
||||
|#
|
||||
|
||||
(require "contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
(require "guts.ss"
|
||||
"opt.ss"
|
||||
scheme/stxparam)
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "contract-opt-guts.ss")
|
||||
(for-syntax "contract-helpers.ss")
|
||||
(for-syntax "opt-guts.ss")
|
||||
(for-syntax "helpers.ss")
|
||||
(for-syntax syntax/stx)
|
||||
(for-syntax syntax/name))
|
||||
|
||||
|
|
@ -15,8 +15,8 @@ improve method arity mismatch contract violation error messages?
|
|||
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/stxparam
|
||||
"contract-guts.ss"
|
||||
"contract-helpers.ss")
|
||||
"guts.ss"
|
||||
"helpers.ss")
|
||||
|
||||
(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference)))
|
||||
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
"contract-base.ss")
|
||||
(require "guts.ss"
|
||||
"opt.ss"
|
||||
"base.ss")
|
||||
(require (for-syntax scheme/base
|
||||
"contract-opt-guts.ss"))
|
||||
"opt-guts.ss"))
|
||||
|
||||
;;
|
||||
;; opt/pred helper
|
||||
|
|
@ -5,7 +5,7 @@
|
|||
build-enforcer-clauses
|
||||
generate-arglists)
|
||||
|
||||
(require "contract-opt-guts.ss")
|
||||
(require "opt-guts.ss")
|
||||
(require (for-template scheme/base)
|
||||
(for-syntax scheme/base))
|
||||
|
||||
|
|
@ -17,13 +17,13 @@ it around flattened out.
|
|||
|
||||
|#
|
||||
|
||||
(require "contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
(require "guts.ss"
|
||||
"opt.ss"
|
||||
mzlib/etc)
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "contract-ds-helpers.ss")
|
||||
(for-syntax "contract-helpers.ss")
|
||||
(for-syntax "contract-opt-guts.ss")
|
||||
(for-syntax "ds-helpers.ss")
|
||||
(for-syntax "helpers.ss")
|
||||
(for-syntax "opt-guts.ss")
|
||||
(for-syntax mzlib/etc))
|
||||
|
||||
(provide define-contract-struct
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "contract-helpers.ss"
|
||||
(require "helpers.ss"
|
||||
scheme/pretty)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
"contract-helpers.ss"))
|
||||
"helpers.ss"))
|
||||
|
||||
(provide raise-contract-error
|
||||
guilty-party
|
||||
|
|
@ -2,11 +2,11 @@
|
|||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/struct-info
|
||||
"contract-helpers.ss"
|
||||
"contract-opt-guts.ss")
|
||||
"helpers.ss"
|
||||
"opt-guts.ss")
|
||||
scheme/promise
|
||||
"contract-opt.ss"
|
||||
"contract-guts.ss")
|
||||
"opt.ss"
|
||||
"guts.ss")
|
||||
|
||||
(provide flat-rec-contract
|
||||
flat-murec-contract
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require "contract-arrow.ss"
|
||||
"contract-guts.ss"
|
||||
"class-internal.ss"
|
||||
(require "arrow.ss"
|
||||
"guts.ss"
|
||||
scheme/private/class-internal
|
||||
scheme/stxparam)
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
|
||||
(for-template scheme/base)
|
||||
(for-template "contract-guts.ss")
|
||||
(for-template "guts.ss")
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide get-opter reg-opter! opter
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
#lang scheme/base
|
||||
(require "contract-guts.ss"
|
||||
(require "guts.ss"
|
||||
scheme/stxparam
|
||||
mzlib/etc)
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "contract-opt-guts.ss")
|
||||
(for-syntax "opt-guts.ss")
|
||||
(for-syntax mzlib/etc)
|
||||
(for-syntax scheme/stxparam))
|
||||
|
||||
|
|
@ -4,11 +4,11 @@
|
|||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
(prefix-in a: "contract-helpers.ss"))
|
||||
"contract-arrow.ss"
|
||||
"contract-base.ss"
|
||||
"contract-exists.ss"
|
||||
"contract-guts.ss")
|
||||
(prefix-in a: "helpers.ss"))
|
||||
"arrow.ss"
|
||||
"base.ss"
|
||||
scheme/contract/exists
|
||||
"guts.ss")
|
||||
|
||||
(define-syntax (verify-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -9,11 +9,11 @@
|
|||
scheme/struct-info
|
||||
syntax/define
|
||||
syntax/kerncase
|
||||
(prefix-in a: "contract-helpers.ss"))
|
||||
(prefix-in a: "private/helpers.ss"))
|
||||
scheme/splicing
|
||||
"contract-arrow.ss"
|
||||
"contract-base.ss"
|
||||
"contract-guts.ss")
|
||||
"private/arrow.ss"
|
||||
"private/base.ss"
|
||||
"private/guts.ss")
|
||||
|
||||
;; These are useful for all below.
|
||||
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require "../private/contract-exists.ss")
|
||||
(require scheme/contract/exists)
|
||||
|
||||
;; this code builds the list of predicates (in case it changes, this may need to be re-run)
|
||||
#;
|
||||
|
|
|
|||
|
|
@ -17,9 +17,9 @@ another. Programmers specify the behavior of a module exports via
|
|||
@scheme[provide/contract] and the contract system enforces those
|
||||
constraints.
|
||||
|
||||
@note-lib[scheme/contract #:use-sources (scheme/private/contract-ds
|
||||
scheme/private/contract-base
|
||||
scheme/private/contract-guts)]
|
||||
@note-lib[scheme/contract #:use-sources (scheme/contract/private/ds
|
||||
scheme/contract/private/base
|
||||
scheme/contract/private/guts)]
|
||||
|
||||
@deftech{Contracts} come in two forms: those constructed by the
|
||||
various operations listed in this section of the manual, and various
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
syntax/stx
|
||||
syntax/kerncase
|
||||
scheme/struct-info
|
||||
scheme/private/contract-helpers
|
||||
scheme/contract/private/helpers
|
||||
(for-syntax scheme/base
|
||||
syntax/kerncase
|
||||
"rep.ss"
|
||||
|
|
|
|||
|
|
@ -195,17 +195,17 @@
|
|||
scheme/mzscheme
|
||||
scheme/nest
|
||||
scheme/private/class-internal
|
||||
scheme/private/contract-base
|
||||
scheme/private/contract-arrow
|
||||
scheme/private/contract-basic-opters
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-ds-helpers
|
||||
scheme/private/contract-exists
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-helpers
|
||||
scheme/private/contract-misc
|
||||
scheme/private/contract-opt
|
||||
scheme/private/contract-opt-guts
|
||||
scheme/contract/private/base
|
||||
scheme/contract/private/arrow
|
||||
scheme/contract/private/basic-opters
|
||||
scheme/contract/private/ds
|
||||
scheme/contract/private/ds-helpers
|
||||
scheme/contract/private/exists
|
||||
scheme/contract/private/guts
|
||||
scheme/contract/private/helpers
|
||||
scheme/contract/private/misc
|
||||
scheme/contract/private/opt
|
||||
scheme/contract/private/opt-guts
|
||||
scheme/private/define-struct
|
||||
scheme/private/define-struct
|
||||
scheme/private/for
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(namespace-require '(for-syntax scheme/base))
|
||||
(namespace-require '(for-template scheme/base))
|
||||
(namespace-require 'scheme/contract)
|
||||
(namespace-require '(only scheme/private/contract-arrow procedure-accepts-and-more?))
|
||||
(namespace-require '(only scheme/contract/private/arrow procedure-accepts-and-more?))
|
||||
(namespace-require 'scheme/class)
|
||||
(namespace-require 'scheme/promise))
|
||||
n))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user