Ohhh, thank you so much, Sorawee! Now I have wealth of code to study.
By the way, I tried to send my full code but apparently once again I hit
the "reply" button instead of "reply all" and I only sent it to David, so
here it is again in case anyone wants to play with it. I haven't
implemented field accessors yet because those are trivial (and since I keep
field names somewhere else, I could implement them differently, like (get
'field mycard), though that would probably be slower).
#lang racket/base
(require (for-syntax racket/base
syntax/parse
racket/syntax)
syntax/parse/define)
(require (only-in racket ~a))
(provide card) ;;;; create a card-out thingy
(define-for-syntax (parse-args xs [rs '()])
(define (fn xs)
(if [null? xs] '[]
[let [(a (car xs))
(bs (cdr xs))]
(cond [(keyword? a) (fn bs)]
[(list? a) (cons (car a) (fn bs))]
[else (cons a (fn bs))])]))
(let [(parsed (fn xs))
(dotlist rs)]
(if [null? dotlist]
parsed [append parsed (list dotlist)])))
(define keyword (string->keyword "~a"))
(define keyword-prefix "#:")
(define keyword-suffix "")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
(require (only-in racket/struct
make-constructor-style-printer))
(define-syntax (protocard stx)
(syntax-case stx ()
([_ super (name fields ... . xs)]
(with-syntax [(descr (format-id #'name "record:~a" #'name))
(pred? (format-id #'name "~a?" #'name))
(maker (format-id #'name "make-~a" #'name))
(ref (format-id #'name "~a-ref" #'name))
(set (format-id #'name "~a-set!" #'name))
(field-names (format-id #'name "*~a-fields" #'name))
(explain (format-id #'name "explain-~a" #'name))
(tag-params (tag-args (syntax->datum #'(fields ...))
(syntax->datum #'xs)))
(plain-params
(cons list (map [λ (x) (format-id #'name "~a" x)]
[parse-args (syntax->datum #'(fields
...))
(syntax->datum #'xs)])))]
;;; éste debería de salir de tag-params
#`[begin
(define field-names '(fields ... . xs))
(define-values (descr maker pred? ref set)
(make-struct-type
'name super (length 'tag-params) 0 #f ;; (- (length
super-fields))
(list (cons prop:custom-write
(make-constructor-style-printer
(λ (obj)
(apply string-append
(symbol->string 'name)
(for/list ((arg 'tag-params) (i
(in-naturals 0)))
(print-params (ref obj i) arg))))
(λ (obj) '()) )))))
(define (explain obj)
(for/list [(p (cdr 'plain-params)) (i (in-naturals 0))]
(list p (ref obj i))))
(define (name fields ... . xs)
(apply maker plain-params))
;;; accessors!!
#|(define whatev
(append 'field-names
'super-fields))|#
;#,@[if ]
]))))
(define-syntax (card stx)
(syntax-case stx ()
([_ (name fields ... . xs)]
#'[protocard #f (name fields ... . xs)])
([_ super (name fields ... . xs)]
#'[protocard super (name fields ... . xs)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(define-for-syntax (tag-args xs [rs '()])
(define parsed
(if [null? xs] '[]
[let ((a (car xs))
(bs (cdr xs)))
(cond ((symbol? a) (cons a (tag-args bs)))
((list? a) (cons a (tag-args bs)))
((keyword? a)
(cons (list a (car bs))
(tag-args (cdr bs)))))]))
(if [null? rs] parsed [append parsed (list rs)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (write-if-not-default a-pair val)
(if [equal? (cadr a-pair) val] ""
[string-append " " (~a val)]))
(define (print-params val arg)
(cond
((symbol? arg)
(string-append " " (~a val)))
((keyword? (car arg))
(let ((x (cadr arg))
(res (string-append " " keyword-prefix
(keyword->string (car arg))
keyword-suffix " " (~a val))))
(if (list? x) ;; if it's a default arg, x (cadr arg) appears as a
list
(if (eq? (cadr x) val) "" ;; don't show if it has the default
value (cadr x)
res) res)))
((list? arg)
(write-if-not-default arg val))))
On Saturday, 18 September 2021 at 03:06:36 UTC+2 [email protected] wrote:
> 2) (card (line . xs)) has only one field, xs. Of course, you could also
>> define it as a normal field which contains a list, but there's some other
>> scenarios where I found it more elegant to represent it as a dotted
>> argument (like representing s-expressions as a struct).
>>
> Oh sorry, that was a typo. I meant currently you expect
>
> > (card (line . xs))
> > (line 1 2 3 4 5 6 7 8 9)
> (line 1 2 3 4 5 6 7 8 9)
>
> to be the output, but I was asking if:
>
> > (card (line . xs))
> > (line 1 2 3 4 5 6 7 8 9)
> (line '(1 2 3 4 5 6 7 8 9))
>
> makes more sense. In any case, your response clears things up that there
> is indeed only one field. You simply want it to be printed like that.
>
> This is actually a pretty fun problem. Here’s a quick prototype. Dropping
> it here in case anyone is interested:
>
> #lang racket
>
> (require syntax/parse/define
> (for-syntax syntax/parse/lib/function-header
> racket/syntax
> racket/list
> racket/struct-info))
>
> (begin-for-syntax
> (struct my-struct-info (fields args ctor)
> #:property prop:procedure
> (λ (inst stx)
> (syntax-parse stx
> [(_ args ...) #`(#,(my-struct-info-ctor inst) args ...)]
> [x:id #'#,(my-struct-info-ctor inst)]))))
>
> (define-syntax-parse-rule (define-accessors+predicate
> {~var struct-id (static values #f)}
> name:id)
> #:with (fields ...) (struct-field-info-list (attribute struct-id.value))
> #:do [(define the-struct-info (extract-struct-info (attribute
> struct-id.value)))]
> #:with predicate (list-ref the-struct-info 2)
> #:with (accessors ...) (list-ref the-struct-info 3)
> #:with new-predicate (format-id #'name "~a?" #'name)
> #:with (new-accessors ...)
> (map (λ (id) (format-id #'name "~a-~a" #'name id)) (attribute fields))
>
> (begin
> (define new-predicate predicate)
> (define new-accessors accessors) ...))
>
> (define-syntax-parse-rule
> (card
> {~optional (~var super-id (static my-struct-info? "card type"))}
> {~and header:function-header (_:id . args)})
>
> #:with ((all-fields ...) all-args)
> (let ([info (attribute super-id.value)])
> (cond
> [info
> (unless (list? (syntax-e (my-struct-info-args info)))
> (raise-syntax-error 'card
> "supertype can't have variadic fields"
> this-syntax))
> #`(({~@ . #,(my-struct-info-fields info)} . header.params)
> ({~@ . #,(my-struct-info-args info)} . args))]
> [else #'(header.params args)]))
>
> #:fail-when (check-duplicates (attribute all-fields) #:key syntax-e)
> "duplicate field name"
>
> (begin
> (struct shadow (all-fields ...)
> #:transparent
> ;; TODO: implement gen:custom-write (probably with
> make-constructor-style-printer)
> ;; to customize struct value printing
> #:reflection-name 'header.name)
> (define-accessors+predicate shadow header.name)
> (define (shadow-ctor . all-args)
> (shadow all-fields ...))
> (define-syntax header.name
> (my-struct-info #'(all-fields ...)
> #'all-args
> #'shadow-ctor))))
>
> (let ()
> (card (hola a b #:c c))
> (println (hola 1 2 #:c 3))
>
> (card (ciao a [b 3]))
> (println (ciao 7))
> (println (ciao 7 4))
>
> (card (line . xs))
> (println (line 1 2 3 4 5 6 7 8 9)))
>
> (let ()
> (card (hola a #:b b))
> (card hola (ciao c))
> (define v (ciao 1 #:b 2 3))
> (println v)
> (println (list (ciao-a v) (ciao-b v) (ciao-c v)))
> (println (list (ciao? v) (hola? v))))
>
> (let ()
> (card (foo . xs))
> ;; uncomment should result in a syntax error
> (card #;foo (bar . ys))
>
> (card (a xs))
> ;; uncomment should result in a syntax error
> (card #;a (b xs))
>
> (void))
>
> What I did not implement is making the struct value printed in the way you
> want, but that can be adjusted by using gen:custom-write. Note that I
> didn’t (re)use struct‘s supertype feature since you want fields in the
> opposite order.
>
>
--
You received this message because you are subscribed to the Google Groups
"Racket Users" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to [email protected].
To view this discussion on the web visit
https://groups.google.com/d/msgid/racket-users/0a94926b-5a19-46e9-b7ea-92b8c83f16fan%40googlegroups.com.
