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 sorawe...@gmail.com 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 racket-users+unsubscr...@googlegroups.com.
To view this discussion on the web visit
https://groups.google.com/d/msgid/racket-users/0a94926b-5a19-46e9-b7ea-92b8c83f16fan%40googlegroups.com.
