XML: support list of objects

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