Clean up and refactor value-parsing

vcarded.scm

@@ -23,68 +23,74 @@
   (prefix uri-common uri:))
 
 
-(define (uri->string uri-or-str)
+;; List of all properties with semicoloned-structured strings.
-  (if (uri:uri? uri-or-str)
+(define vcard-semicoloned-properties
-      (uri:uri->string uri-or-str)
+  '(ADR CLIENTPIDMAP GENDER N))
-      uri-or-str))
 
 
-(define (string->uri . strs)
+;; List of all properties with datetime values.
-  (if (and (not (null? strs))
+(define vcard-datetime-properties
-           (string? (car strs)))
+  '(ANNIVERSARY BDAY REV TZ))
-      (uri:uri-reference (string-join strs ";"))
-      strs))
 
 
-(define (csv-string->list str)
+;; List of all properties with multiple comma-separated values.
-  (string-split str ","))
+(define vcard-csv-properties
+  '(CATEGORIES NICKNAME))
 
 
-(define (list->csv-string list)
+;; List of all URL-type vcard properties.
-  (string-join list ","))
+(define vcard-url-properties
+  '(CALADRURI CALURI FBURL GEO IMPP
+    KEY LOGO MEMBER PHOTO RELATED
+    SOUND SOURCE TEL UID URL))
 
 
+;; A list of the parser/serializer functions for each vcard property.
+;;    ((TEL #<procedure> #<procedure>)
+;;     (ADR #<procedure> #<procedure>)
+;;     …)
 (define vcard-value-parsers
-  (list
+   (append
-   (list 'PHOTO string->uri uri->string)
+    (map (lambda (uri-prop)
-   (list 'LOGO string->uri uri->string)
+           (list uri-prop
-   (list 'MEMBER string->uri uri->string)
+                 (lambda strs (or (uri:uri-reference (string-join strs ";"))
-   (list 'SOUND string->uri uri->string)
+                                  (string-join sts ";")))
-   (list 'UID string->uri uri->string)
+                 (lambda (url) (uri:uri->string url))))
-   (list 'URL string->uri uri->string)
+         vcard-url-properties)
-   (list 'KEY string->uri uri->string)
+    (map (lambda (csv-prop)
-   (list 'FBURL string->uri uri->string)
+           (list csv-prop
-   (list 'CALADRURI string->uri uri->string)
+                 (lambda (str) (string-split-unescaped str ","))
-   (list 'CALURI string->uri uri->string)
+                 (lambda (csv-list) (string-join csv-list ","))))
-   (list 'RELATED string->uri uri->string)
+         vcard-csv-properties)
-   (list 'CATEGORIES csv-string->list list->csv-string)
+    (map (lambda (semicolon-prop)
-   (list 'IMPP string->uri uri->string)
+           (list semicolon-prop
-   (list 'GEO string->uri uri->string)))
+                 (lambda (str) (string-split-unescaped str ";"))
-
+                 (lambda (sc-list) (string-join sc-list ";"))))
-
+         vcard-semicoloned-properties)))
-;; Splits a string into a list of CRLF’d lines.
-(define (unlines lines)
-  (string-join lines "\r\n"))
-
-
-;; Splits a string into a list of CRLF’d lines.
-(define (lines string)
-  (remove string-null? (string-split string "\r\n")))
 
 
 ;; Splits a line into a cons of the property-string and value-string.
 ;; … basically splits the string along the first unescaped colon (:).
 ;;    "apple\:berry:mom:dad" → ("apple\:berry" . "mom:dad")
 (define (split-vcard-line line)
-  (let [(split (string-split-nonescaped line ":"))]
+  (let [(split (string-split-unescaped line ":"))]
     (cons (car split)
           (string-join (cdr split) ":"))))
 
 
+;; Ignore whatever conditions the expression might return; just return the
+;; default value in that case.
+;;    (ignore-error (+ 1 "seven") 3) → 3
+(define-syntax ignore-error
+  (syntax-rules ()
+    ((ignore-error expr default)
+     (condition-case expr (var () default)))))
+
+
 ;; Splits a string along a delimiter; while not splitting along
 ;; backslash-escaped delimiters. With “;” as the delimiter:
 ;;    "Bird;dad;apple\;mom" → ("Bird" "dad" "apple\;mom")
-(define (string-split-nonescaped string delimiter)
+(define (string-split-unescaped string delimiter)
   (let [(appendee "")]
     (remove
      not
@@ -108,7 +114,9 @@
 (define (parse-vcard-value prop elements)
   (let [(parser-and-unparser-funcs (alist-ref prop vcard-value-parsers))]
     (if parser-and-unparser-funcs
-        (list (apply (car parser-and-unparser-funcs) (list elements)))
+        (list (ignore-error (apply (car parser-and-unparser-funcs)
+                                   (list elements))
+                            elements))
         (list elements))))
 
 
@@ -116,7 +124,7 @@
 ;;    (KEY ("keyprop1=d" "keyprop2=b") "VALUE" ("valprop1=a" "valprop2=b"))
 (define (parse-vcard-line line)
   (let* [(prop-value-strings (split-vcard-line line))
-         (prop-elements (string-split-nonescaped (car prop-value-strings) ";"))
+         (prop-elements (string-split-unescaped (car prop-value-strings) ";"))
          (value-elements (cdr prop-value-strings))
          (property (string->symbol (string-upcase (car prop-elements))))]
     (append (parse-vcard-prop property (cdr prop-elements))