struct-plus-plus module

[dstorrs]

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))

[spdegabrielle]

Thank you David @dstorrs