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

Move syntax class code into internal forms.

Browse Source
This commit is contained in:
Eric Dobson 2013-11-12 22:28:25 -08:00
parent 12ad3ddf25
commit 0434974426
6 changed files with 104 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

@ -1,8 +1,27 @@
#lang racket/base
(require (for-syntax racket/base)
syntax/parse)
(require
syntax/parse
(for-syntax racket/base racket/syntax
syntax/parse syntax/parse/experimental/template)
(for-template racket/base))
(provide
type-alias
type-refinement
typed-struct
typed-struct/exec
typed-require
typed-require/struct
predicate-assertion
type-declaration
failed-typecheck
type-alias?
typed-struct?
typed-struct/exec?)
;; Forms
(define-syntax-rule (internal-forms set-name nms ...)
(begin
(provide nms ... set-name)
@ -20,3 +39,78 @@
:-internal
typecheck-fail-internal)
;;; Helpers
(define-splicing-syntax-class dtsi-fields
#:attributes (mutable type-only maker)
(pattern
(~seq
(~or (~optional (~and #:mutable (~bind (mutable #t))))
(~optional (~and #:type-only (~bind (type-only #t))))
(~optional (~seq #:maker maker))) ...)))
(define-syntax-class struct-name
(pattern nm:id)
(pattern (nm:id parent:id)))
(define-syntax-class define-typed-struct-body
#:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1))
(pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields)
#:attr name #'nm.nm
#:attr mutable (attribute options.mutable)
#:attr type-only (attribute options.type-only)
#:attr maker (or (attribute options.maker) #'nm.nm)))
;;; Internal form syntax matching
(define-syntax-class internal
#:attributes (value)
#:literals (values)
#:literal-sets (kernel-literals)
(pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values)))))
(define-syntax (define-internal-classes stx)
(define-syntax-class clause
(pattern [name:id (lit:id . body:expr)]
#:with pred (format-id #'name "~a?" #'name)))
(syntax-parse stx
[(_ :clause ...)
(template
(begin
(begin
(define-syntax-class name
#:auto-nested-attributes
#:literal-sets ((internal-literals #:at name))
(pattern i:internal #:with (lit . body) #'i.value))
(define pred
(syntax-parser
[(~var _ name) #t]
[_ #f]))) ...))]))
(define-internal-classes
[type-alias
(define-type-alias-internal name type)]
[type-refinement
(declare-refinement-internal predicate)]
[typed-struct
(define-typed-struct-internal . :define-typed-struct-body)]
[typed-struct/exec
(define-typed-struct/exec-internal nm ([fields:id : types] ...) proc-type)]
[typed-require
(require/typed-internal name type)]
[typed-require/struct
(require/typed-internal name type #:struct-maker parent)]
[predicate-assertion
(assert-predicate-internal type predicate)]
[type-declaration
(:-internal id:identifier type)]
[failed-typecheck
(typecheck-fail-internal stx message:str var:id)])

3
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -8,12 +8,13 @@
(types utils abbrev union subtype type-table)
(private-in parse-type type-annotation syntax-properties)
(rep type-rep filter-rep object-rep)
(utils tc-utils syntax-classes)
(utils tc-utils)
(env lexical-env tvar-env index-env)
racket/private/class-internal
syntax/parse syntax/stx
unstable/syntax
(only-in srfi/1 split-at)
(typecheck internal-forms)
(for-template (only-in '#%paramz [parameterization-key pz:pk])))
(require (for-template racket/base racket/private/class-internal))

3
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -7,9 +7,8 @@
(private type-annotation parse-type syntax-properties)
(env lexical-env type-alias-env global-env type-env-structs scoped-tvar-env)
(rep type-rep filter-rep)
(utils syntax-classes)
syntax/free-vars
(typecheck signatures tc-metafunctions tc-subst)
(typecheck signatures tc-metafunctions tc-subst internal-forms)
racket/match (contract-req)
syntax/parse syntax/stx
(for-template racket/base))

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

@ -9,8 +9,8 @@
(private parse-type syntax-properties)
(types abbrev utils resolve substitute type-table struct-table)
(env global-env type-name-env tvar-env)
(utils tc-utils syntax-classes)
(typecheck def-binding)
(utils tc-utils)
(typecheck def-binding internal-forms)
(for-syntax syntax/parse racket/base)
(for-template racket/base))

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -9,8 +9,9 @@
(private parse-type type-annotation type-contract syntax-properties)
(env global-env init-envs type-name-env type-alias-env
lexical-env env-req mvar-env scoped-tvar-env)
(utils tc-utils syntax-classes)
(typecheck provide-handling def-binding tc-structs typechecker)
(utils tc-utils)
(typecheck provide-handling def-binding tc-structs
typechecker internal-forms)
syntax/location

97
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-classes.rkt
View File

@ -1,97 +0,0 @@
#lang racket/base
(require
(only-in "utils.rkt" typecheck)
syntax/parse
(for-syntax racket/base racket/syntax
syntax/parse syntax/parse/experimental/template)
(only-in (typecheck internal-forms) internal-literals)
(for-template racket/base))
(provide
type-alias
type-refinement
typed-struct
typed-struct/exec
typed-require
typed-require/struct
predicate-assertion
type-declaration
failed-typecheck
type-alias?
typed-struct?
typed-struct/exec?
)
;;; Helpers
(define-splicing-syntax-class dtsi-fields
#:attributes (mutable type-only maker)
(pattern
(~seq
(~or (~optional (~and #:mutable (~bind (mutable #t))))
(~optional (~and #:type-only (~bind (type-only #t))))
(~optional (~seq #:maker maker))) ...)))
(define-syntax-class struct-name
(pattern nm:id)
(pattern (nm:id parent:id)))
(define-syntax-class define-typed-struct-body
#:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1))
(pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields)
#:attr name #'nm.nm
#:attr mutable (attribute options.mutable)
#:attr type-only (attribute options.type-only)
#:attr maker (or (attribute options.maker) #'nm.nm)))
;;; Internal form syntax matching
(define-syntax-class internal
#:attributes (value)
#:literals (values)
#:literal-sets (kernel-literals)
(pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values)))))
(define-syntax (define-internal-classes stx)
(define-syntax-class clause
(pattern [name:id (lit:id . body:expr)]
#:with pred (format-id #'name "~a?" #'name)))
(syntax-parse stx
[(_ :clause ...)
(template
(begin
(begin
(define-syntax-class name
#:auto-nested-attributes
#:literal-sets ((internal-literals #:at name))
(pattern i:internal #:with (lit . body) #'i.value))
(define pred
(syntax-parser
[(~var _ name) #t]
[_ #f]))) ...))]))
(define-internal-classes
[type-alias
(define-type-alias-internal name type)]
[type-refinement
(declare-refinement-internal predicate)]
[typed-struct
(define-typed-struct-internal . :define-typed-struct-body)]
[typed-struct/exec
(define-typed-struct/exec-internal nm ([fields:id : types] ...) proc-type)]
[typed-require
(require/typed-internal name type)]
[typed-require/struct
(require/typed-internal name type #:struct-maker parent)]
[predicate-assertion
(assert-predicate-internal type predicate)]
[type-declaration
(:-internal id:identifier type)]
[failed-typecheck
(typecheck-fail-internal stx message:str var:id)])