diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-24 15:55:10 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-01 12:32:20 +0200 |
commit | b0d75f5b0ccb4bbe90663bb22dc92daece8c5fcd (patch) | |
tree | e6a98d908191c258f4c8a641604d522a03f64800 /src | |
parent | 98de254d3c77feadad464f77f51f9cad5993a9f8 (diff) |
XML: support list of objects
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/serializable.scm | 147 |
1 files changed, 91 insertions, 56 deletions
diff --git a/src/scm/webid-oidc/serializable.scm b/src/scm/webid-oidc/serializable.scm index f05206c..b47f7db 100644 --- a/src/scm/webid-oidc/serializable.scm +++ b/src/scm/webid-oidc/serializable.scm @@ -79,19 +79,64 @@ (define-class <parser-state> ()) -(define-class <parser-reading-element> (<parser-state>) +(define-class <parser-reading-value> (<parser-state>)) + +(define-class <parser-reading-element> (<parser-reading-value>) (namespace #:init-keyword #:namespace #:accessor namespace) (init-class #:init-keyword #:init-class #:accessor init-class) (init-args-reverse #:init-keyword #:init-args-reverse #:accessor init-args-reverse)) +(define-class <parser-reading-list> (<parser-reading-value>) + (items-reverse #:init-keyword #:items-reversed #:accessor items-reversed #:init-value '())) + (define-class <parser-reading-extended-attribute> (<parser-state>) (attribute-name #:init-keyword #:attribute-name #:accessor attribute-name) (attribute-value #:init-keyword #:attribute-value #:accessor attribute-value #:init-value #f)) (define-class <parser-root> (<parser-reading-extended-attribute>)) +(define-method (get-value (list <parser-reading-list>)) + (reverse (items-reverse list))) + +(define-method (get-value (element <parser-reading-element>)) + (let* ((class (init-class element)) + (with-slots + (filter-map + (match-lambda + ((name . value) + (let ((slot (class-slot-definition class name))) + (and slot `(,slot . ,value))))) + (reverse (init-args-reverse element)))) + (initializable/non-initializable + (receive (initializable non-initializable) + (partition (match-lambda + ((slot . value) + (slot-definition-init-keyword slot))) + with-slots) + (let collect-initializable ((initializable initializable) + (collected '())) + (match initializable + (() + `(,(reverse collected) + . ,(map (match-lambda + ((slot . value) + (lambda (x) + (slot-set! x (slot-definition-name slot) value)))) + non-initializable))) + (((slot . value) initializable ...) + (collect-initializable + initializable + `(,value ,(slot-definition-init-keyword slot) ,@collected))))))) + (initializable (car initializable/non-initializable)) + (non-initializable (cdr initializable/non-initializable))) + (let ((object (apply make class initializable))) + (for-each (lambda (finish!) (finish! object)) non-initializable) + object))) + (define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-extended-attribute>)) (match elem-gi + (('guile . 'list) + (make <parser-reading-list>)) ((namespace . local-name) (let ((namespace-parsed (map string->symbol @@ -115,6 +160,13 @@ #:attribute-name local-name)) (else state))) +(define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-list>)) + (new-level-seed elem-gi attributes namespaces expected-content + (make <parser-reading-extended-attribute> + #:namespace '(guile) + #:init-class <list> + #:init-args-reverse '()))) + (define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-element>) (seed <parser-reading-extended-attribute>)) (let ((ret (shallow-clone parent-seed))) (set! (init-args-reverse ret) @@ -122,42 +174,18 @@ ,@(init-args-reverse ret))) ret)) -(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-extended-attribute>) (seed <parser-reading-element>)) - (let* ((class (init-class seed)) - (with-slots - (filter-map - (match-lambda - ((name . value) - (let ((slot (class-slot-definition class name))) - (and slot `(,slot . ,value))))) - (reverse (init-args-reverse seed)))) - (initializable/non-initializable - (receive (initializable non-initializable) - (partition (match-lambda - ((slot . value) - (slot-definition-init-keyword slot))) - with-slots) - (let collect-initializable ((initializable initializable) - (collected '())) - (match initializable - (() - `(,(reverse collected) - . ,(map (match-lambda - ((slot . value) - (lambda (x) - (slot-set! x (slot-definition-name slot) value)))) - non-initializable))) - (((slot . value) initializable ...) - (collect-initializable - initializable - `(,value ,(slot-definition-init-keyword slot) ,@collected))))))) - (initializable (car initializable/non-initializable)) - (non-initializable (cdr initializable/non-initializable))) - (let ((object (apply make class initializable))) - (for-each (lambda (finish!) (finish! object)) non-initializable) - (let ((ret (shallow-clone parent-seed))) - (set! (attribute-value ret) object) - ret)))) +(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-extended-attribute>) (seed <parser-reading-value>)) + (let ((object (get-value seed))) + (let ((ret (shallow-clone parent-seed))) + (set! (attribute-value ret) object) + ret))) + +(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-list>) (seed <parser-reading-value>)) + (let ((object (get-value seed))) + (let ((ret (shallow-clone parent-seed))) + (set! (items-reversed ret) + `(,object ,@(items-reversed ret))) + ret))) (define-method (char-data-handler string1 string2 (seed <parser-reading-extended-attribute>)) (match (attribute-value seed) @@ -186,22 +214,29 @@ (define (->sxml object) (let ((class (class-of object))) - (if (is-a? class <plugin-class>) - (let ((namespace - (encode-and-join-uri-path - (map symbol->string (module-name class))))) - (let ((all-slots (class-slots class))) - (define (get-slot-value slot) - (let ((name (slot-definition-name slot))) - (let-keywords - (slot-definition-options slot) #t - ((->sxml ->sxml)) - (catch 'slot-unbound - (lambda () - (let ((value (slot-ref object name))) - `((,name ,(->sxml value))))) - (lambda _ - '()))))) - `(,(direct-name class) (@ (xmlns ,namespace)) - ,@(apply append (map get-slot-value all-slots))))) - (call-with-output-string (lambda (port) (display object port)))))) + (cond + ((is-a? class <plugin-class>) + (let ((namespace + (encode-and-join-uri-path + (map symbol->string (module-name class))))) + (let ((all-slots (class-slots class))) + (define (get-slot-value slot) + (let ((name (slot-definition-name slot))) + (let-keywords + (slot-definition-options slot) #t + ((->sxml ->sxml)) + (if (eq? ->sxml 'ignore) + '() + (catch 'slot-unbound + (lambda () + (let ((value (slot-ref object name))) + `((,name ,(->sxml value))))) + (lambda _ + '())))))) + `(,(direct-name class) (@ (xmlns ,namespace)) + ,@(apply append (map get-slot-value all-slots)))))) + ((list? object) + `(list (@ (xmlns "guile")) + ,@(map ->sxml object))) + (else + (call-with-output-string (lambda (port) (display object port))))))) |