struct-plus-plus module #18
Description
struct-plus-plus can be found here: https://pkgs.racket-lang.org/package/struct-plus-plus
It allows for creation of struct types that come with: keyword constructors, per-field contracts and wrapper functions, dotted accessors, auto-generated functions to convert to/from the struct, functional setters and updaters, dependency checking among fields, easy introspection, and reflection.
Simple Example:
#lang racket
(require struct-plus-plus)
(struct++ person
([name (not/c (curry equal? "")) ~a]
[(age +nan.0) (or/c +nan.0 positive?)])
(#:rule ("no eugenes"
#:check (name) [(not (equal? "eugene" (string-downcase (~a name))))])
#:convert-from (vector (vector? (vector name age) (name age)))
)
#:transparent)
(define alice (person++ #:name "alice" #:age 18))
(display "manual creation: ") alice
(display "converted from vector: ") (vector->person++ (vector "alice" 18))
(person.name alice)
(person++ #:name "bob")
(person++ #:name 'tom #:age 83)
(person++ #:name "eugene")
Running this produces:
manual creation: (person "alice" 18)
converted from vector: (person "alice" 18)
"alice"
(person "bob" +nan.0)
(person "tom" 83)
; failed in struct++ rule named 'no eugenes' (type: check): check failed
; name: "eugene"
; Context:
; /Users/dstorrs/Library/Racket/8.0/pkgs/struct-plus-plus/main.rkt:328:10
Code
The following code is a compilation of two files:
;;======== main.rkt =========
#lang racket/base
(require racket/require
(multi-in handy (hash struct))
(multi-in racket (bool contract/base contract/region function match promise))
(only-in racket/list count flatten)
"reflection.rkt"
(for-syntax racket/base
(only-in racket/list partition)
racket/syntax
syntax/parse
syntax/parse/class/struct-id
syntax/parse/experimental/template)
)
(provide struct++ struct->hash (all-from-out "reflection.rkt"))
;;======================================================================
(begin-for-syntax
; Set up various syntax classes and metafunctions. struct++ itself
; is defined below this begin-for-syntax
;; syntax->keyword was lifted from:
;; http://www.greghendershott.com/2015/07/keyword-structs-revisited.html
(define syntax->keyword (compose1 string->keyword symbol->string syntax->datum))
;;--------------------------------------------------
(define-template-metafunction (make-dotted-accessor stx)
(syntax-parse stx
[(make-dotted-accessor #f _ _ _ _ _ _)
#''()]
[(make-dotted-accessor #t
struct-id ctor-id predicate
field-name field-contract wrapper)
(with-syntax ([accessor-name (format-id #'struct-id
"~a-~a"
#'struct-id
#'field-name)]
[dotted-accessor-name (format-id #'struct-id
"~a.~a"
#'struct-id
#'field-name)])
(template (define dotted-accessor-name accessor-name)))]))
;;--------------------------------------------------
(define-template-metafunction (make-functional-setter stx)
(syntax-parse stx
[(make-functional-setter #f _ _ _ _ _ _)
#''()]
[(make-functional-setter #t
struct-id ctor-id predicate
field-name field-contract wrapper)
(with-syntax ([setter-name (format-id #'struct-id
"set-~a-~a"
#'struct-id
#'field-name)])
(template
(define/contract (setter-name instance val)
(-> predicate field-contract predicate)
(hash->struct/kw ctor-id
(safe-hash-set (struct->hash struct-id instance)
'field-name
(wrapper val))))))]))
;;--------------------------------------------------
(define-template-metafunction (make-functional-updater stx )
(syntax-parse stx
[(make-functional-updater #f
struct-id ctor-id predicate
field-name field-contract wrapper)
#''()
]
[(make-functional-updater #t
struct-id ctor-id predicate
field-name field-contract wrapper)
(with-syntax ([updater-name (format-id #'struct-id
"update-~a-~a"
#'struct-id
#'field-name)]
[getter (format-id #'struct-id
"~a-~a"
#'struct-id
#'field-name)]
)
(template
(define/contract (updater-name instance updater)
(-> predicate (-> field-contract field-contract) predicate)
(hash->struct/kw ctor-id
(safe-hash-set (struct->hash struct-id instance)
'field-name
(wrapper (updater (getter instance))))))))]))
;;--------------------------------------------------
(define-template-metafunction (make-convert-for-function-name stx)
(syntax-parse stx
[(make-convert-for-function-name struct-id purpose)
(format-id #'struct-id "~a/convert->~a" #'struct-id #'purpose)]))
;;--------------------------------------------------
(define-template-metafunction (make-convert-for-function stx)
(syntax-parse stx
[(make-convert-for-function struct-id purpose predicate arg ...)
(template
(define/contract ((make-convert-for-function-name struct-id purpose) instance)
(-> predicate any)
(hash-remap (struct->hash struct-id instance) (~@ arg ...))))]))
;;--------------------------------------------------
(define-template-metafunction (make-accessor-name stx)
(syntax-parse stx
[(make-accessor-name struct-name field-name)
(format-id #'struct-name "~a-~a" #'struct-name #'field-name)]))
;;--------------------------------------------------
(define-template-metafunction (make-field-struct stx)
(syntax-parse stx
[(make-field-struct struct-name field-name contract wrapper default)
#'(struct++-field ('field-name
(make-accessor-name struct-name field-name)
contract
wrapper
default))]))
;;--------------------------------------------------
(define-template-metafunction (make-convert-from-function stx)
(syntax-parse stx
[(make-convert-from-function struct-id:id name:id source-predicate:expr
match-clause:expr (f:field ...))
(with-syntax ([func-name (format-id #'struct-id "~a->~a++" #'name #'struct-id)]
[struct-predicate (format-id #'struct-id "~a?" #'struct-id)]
[ctor (format-id #'struct-id "~a++" #'struct-id)]
[((ctor-arg ...) ...) #'(f.ctor-arg ...)])
(template
(define/contract (func-name val)
(-> source-predicate struct-predicate)
(match val
[match-clause (ctor ctor-arg ... ...)]))))]))
;;----------------------------------------------------------------------
(define-template-metafunction (make-ctor-contract stx)
(define-syntax-class contract-spec
(pattern (required?:boolean (name:id contr:expr))))
;;
(syntax-parse stx
#:datum-literals (make-ctor-contract)
[(make-ctor-contract (item:contract-spec ...+ predicate))
(let-values
([(mandatory optional)
(partition (syntax-parser [(flag _) (syntax-e #'flag)])
(map (syntax-parser [(flag (name contr))
(quasitemplate (flag (#,(syntax->keyword #'name)
contr)))])
(syntax->list #'(item ...))))])
(with-syntax ((((_ (mand-kw mand-contract)) ...) mandatory)
(((_ (opt-kw opt-contract)) ...) optional))
(template (->* ((?@ mand-kw mand-contract) ...)
((?@ opt-kw opt-contract) ...)
predicate))))]))
;;--------------------------------------------------
(define-syntax-class field
(pattern (~or id:id
[id:id (~optional (~seq cont:expr (~optional wrap:expr)))])
#:with required? #'#t
#:with field-contract (template (?? cont any/c))
#:with wrapper (template (?? wrap identity))
#:with ctor-arg #`(#,(syntax->keyword #'id) id)
#:with def #''no-default-given)
(pattern [(id:id default-value:expr)
(~optional (~seq cont:expr (~optional wrap:expr)))]
#:with required? #'#f
#:with field-contract (template (?? cont any/c))
#:with wrapper (template (?? wrap identity))
#:with ctor-arg #`(#,(syntax->keyword #'id) [id default-value])
#:with def (template default-value)
)
)
;;--------------------------------------------------
(define-splicing-syntax-class rule
(pattern
(~seq #:rule (rule-name:str (~seq #:transform target (var:id ...) [code:expr ...+])))
#:with type #''transform
#:with result (template (set! target ((lambda (var ...) code ...) var ...))))
(pattern
(~seq #:rule (rule-name:str (~seq #:check (var:id ...) [code:expr])))
#:with type #''check
#:with result (template
((lambda (var ...)
(when (not code)
(let ([args (flatten (map list
(map symbol->string '(var ...))
(list var ...)))])
(apply raise-arguments-error
(string->symbol (format "failed in struct++ rule named '~a' (type: check)" rule-name))
"check failed"
args))))
var ...)))
(pattern
(~seq #:rule
(rule-name:str (~seq #:at-least
min-ok:exact-positive-integer
(~optional predicate:expr)
(var:id ...))))
#:with type #''at-least
#:with result (template
(let* ([pred (?? predicate (procedure-rename
(negate false?)
'true?))]
[num-valid (count pred (list var ...))])
(when (< num-valid min-ok )
(let ([args (flatten (map list
(map symbol->string '(var ...))
(list var ...)))])
(apply raise-arguments-error
(string->symbol (format "failed in struct++ rule named '~a' (type: at-least)" rule-name))
"too many invalid fields"
"minimum allowed" min-ok
"predicate" pred
args)))))))
;;--------------------------------------------------
(define-splicing-syntax-class converter
(pattern (~seq #:convert-for (name (opt ...)))))
; e.g. #:convert-from (db-row (vector? (vector a b c) (a b c)))
(define-splicing-syntax-class convert-from-clause
(pattern (~seq #:convert-from (name:id (source-predicate:expr
match-clause:expr
(f:field ...+))))))
;;--------------------------------------------------
(define-splicing-syntax-class make-setters-clause
(pattern (~seq #:make-setters? yes?:boolean)))
;;--------------------------------------------------
(define-splicing-syntax-class make-dotted-accessors-clause
(pattern (~seq #:make-dotted-accessors? yes?:boolean)))
)
(define-syntax struct->hash
(syntax-parser
[(_ s:struct-id instance:expr)
(template
(let* ([name-str (symbol->string (object-name s.constructor-id))]
[field-name (lambda (f)
(string->symbol
(regexp-replace (pregexp (string-append name-str "-"))
(symbol->string (object-name f))
"")))]
)
(make-immutable-hash (list (cons (field-name s.accessor-id)
(s.accessor-id instance)
) ...))))]))
;;======================================================================
(define-syntax (struct++ stx)
(syntax-parse stx
((struct++ struct-id:id
(field:field ...)
(~optional ((~alt (~optional make-setters:make-setters-clause)
(~optional make-dotted-accessors:make-dotted-accessors-clause)
(~optional (~and #:omit-reflection omit-reflection))
;converters:converter-list
c:converter
cfrom:convert-from-clause
r:rule)
...))
opt ...)
#:with ctor-id (format-id #'struct-id "~a++" #'struct-id)
#:with predicate (format-id #'struct-id "~a?" #'struct-id)
#:with reflectance-data (if (attribute omit-reflection)
#'()
#'(#:property prop:struct++
(delay
(struct++-info++
#:base-constructor struct-id ; base struct constructor
#:constructor ctor-id ; struct-plus-plus constructor
#:predicate predicate
#:fields (list (struct++-field++
#:name 'field.id
#:accessor (make-accessor-name
struct-id
field.id)
#:contract field.field-contract
#:wrapper field.wrapper
#:default field.def)
...)
#:rules
(list (~? (~@ (struct++-rule++
#:name r.rule-name
#:type r.type)
...)))
#:converters
(list
(~? (~@ (make-convert-for-function-name
struct-id
c.name)
...)))))))
; A double ... (used below) flattens one level
(with-syntax* ([((ctor-arg ...) ...) #'(field.ctor-arg ...)])
(quasitemplate
(begin
(struct struct-id (field.id ...) opt ... (~@ . reflectance-data))
;
(define/contract (ctor-id ctor-arg ... ...)
(make-ctor-contract
((field.required? (field.id field.field-contract)) ... predicate))
(?? (?@ r.result ...))
(struct-id (field.wrapper field.id) ...)
)
;
(?? (?@ (make-convert-for-function struct-id c.name predicate c.opt ...) ...))
;
(?? (?@ (make-convert-from-function struct-id
cfrom.name
cfrom.source-predicate
cfrom.match-clause
(cfrom.f ...)) ...))
;
(begin
(make-dotted-accessor (?? make-dotted-accessors.yes? #t)
struct-id ctor-id predicate
field.id
field.field-contract
field.wrapper
)
...)
(begin
(make-functional-setter (?? make-setters.yes? #t)
struct-id ctor-id predicate
field.id
field.field-contract
field.wrapper
)
...)
(begin
(make-functional-updater (?? make-setters.yes? #t)
struct-id ctor-id predicate
field.id
field.field-contract
field.wrapper
)
...)))))))
;;======== reflection.rkt =========
#lang racket
(provide (struct-out struct++-rule)
(struct-out struct++-field)
(struct-out struct++-info)
struct++-info++
struct++-field++
struct++-rule++
prop:struct++ struct++? struct++-ref)
(struct struct++-rule (name type))
(struct struct++-field (name accessor contract wrapper default))
(struct struct++-info
(base-constructor constructor predicate fields rules converters))
(define-values (prop:struct++ struct++? struct++-ref)
(make-struct-type-property 'struct++ 'can-impersonate))
;;----------------------------------------------------------------------
(define/contract (struct++-rule++ #:name name #:type type)
(-> #:name string? #:type (or/c 'at-least 'transform 'check)
struct++-rule?)
(struct++-rule name type))
;;----------------------------------------------------------------------
(define/contract (struct++-field++
#:name name
#:accessor accessor
#:contract [field-contract any/c]
#:wrapper [wrapper identity]
#:default [default 'no-default-given])
(->* (#:name symbol?
#:accessor (-> any/c any/c))
(#:contract contract?
#:wrapper procedure?
#:default any/c)
struct++-field?)
(struct++-field name accessor field-contract wrapper default))
;;----------------------------------------------------------------------
(define/contract (struct++-info++
#:base-constructor base-constructor
#:constructor constructor
#:predicate predicate
#:fields fields
#:rules rules
#:converters converters)
(-> #:base-constructor procedure?
#:constructor procedure?
#:predicate predicate/c
#:fields (listof struct++-field?)
#:rules (listof struct++-rule?)
#:converters (listof procedure?)
struct++-info?)
(struct++-info base-constructor constructor predicate fields rules converters))