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

Remove duplication.

Browse Source
This commit is contained in:
Eric Dobson 2013-11-12 09:13:03 -08:00
parent d3ecec9c8b
commit d582245395
1 changed files with 42 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,11 +2,13 @@
(require (require
(only-in "utils.rkt" typecheck) (only-in "utils.rkt" typecheck)
syntax/parse syntax/parse
(for-syntax racket/base racket/syntax
syntax/parse syntax/parse/experimental/template)
(for-template (typecheck internal-forms)) (for-template (typecheck internal-forms))
(for-template racket/base)) (for-template racket/base))
(provide (provide
type-alias type-alias
type-refinement type-refinement
typed-struct typed-struct
typed-struct/exec typed-struct/exec
@ -14,7 +16,7 @@
typed-require/struct typed-require/struct
predicate-assertion predicate-assertion
type-declaration type-declaration
type-alias? type-alias?
typed-struct? typed-struct?
typed-struct/exec? typed-struct/exec?
@ -26,63 +28,44 @@
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
(pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values))))) (pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values)))))
(define-syntax (define-internal-classes stx)
(define-syntax-class clause
(pattern [name:id (~optional (~seq #:attributes attributes:expr))
(lit:id . body:expr)]
#:with pred (format-id #'name "~a?" #'name)))
(define-syntax-class type-alias (syntax-parse stx
#:attributes (name type) [(_ :clause ...)
(pattern i:internal (template
#:with ((~literal define-type-alias-internal) name type) #'i.value)) (begin
(begin
(define-syntax-class name
(?? (?@ #:attributes attributes))
(pattern i:internal
#:with ((~literal lit) . body) #'i.value))
(define pred
(syntax-parser
[(~var _ name) #t]
[_ #f]))) ...))]))
(define-syntax-class type-refinement (define-internal-classes
#:attributes (predicate) [type-alias
(pattern i:internal (define-type-alias-internal name type)]
#:with ((~literal declare-refinement-internal) predicate) #'i.value)) [type-refinement
(declare-refinement-internal predicate)]
(define-syntax-class typed-struct [typed-struct
#:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1)) #:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1))
(pattern i:internal (define-typed-struct-internal . :define-typed-struct-body)]
#:with ((~literal define-typed-struct-internal) . :define-typed-struct-body) #'i.value)) [typed-struct/exec
(define-typed-struct/exec-internal nm ([fields:id : types] ...) proc-type)]
(define-syntax-class typed-struct/exec [typed-require
#:attributes (nm proc-type (fields 1) (types 1)) (require/typed-internal name type)]
(pattern i:internal [typed-require/struct
#:with ((~literal define-typed-struct/exec-internal) (require/typed-internal name type #:struct-maker parent)]
nm ([fields:id : types] ...) proc-type) #'i.value)) [predicate-assertion
(assert-predicate-internal type predicate)]
(define-syntax-class typed-require [type-declaration
#:attributes (name type) (:-internal id:identifier type)])
(pattern i:internal
#:with ((~literal require/typed-internal) name type) #'i.value))
(define-syntax-class typed-require/struct
#:attributes (name type)
(pattern i:internal
#:with ((~literal require/typed-internal) name type #:struct-maker parent) #'i.value))
(define-syntax-class predicate-assertion
#:attributes (type predicate)
(pattern i:internal
#:with ((~literal assert-predicate-internal) type predicate) #'i.value))
(define-syntax-class type-declaration
#:attributes (id type)
(pattern i:internal
#:with ((~literal :-internal) id:identifier type) #'i.value))
(define type-alias?
(syntax-parser
[:type-alias #t]
[_ #f]))
(define typed-struct?
(syntax-parser
[:typed-struct #t]
[_ #f]))
(define typed-struct/exec?
(syntax-parser
[:typed-struct/exec #t]
[_ #f]))
;;; Helpers ;;; Helpers