email: Support emacs message mode parens style addresses.

* email/email.scm (define-comment-pattern, define-cfws-pattern,
define-dot-atom-pattern, define-domain-pattern,
define-addr-spec-pattern): New macros.
(captured-comment, captured-cfws, captured-dot-atom, captured-domain,
captured-addr-spec): New patterns.
(mailbox): Use captured-addr-spec instead of addr-spec.
(post-process-mailbox): Handle emacs message mode parens style addresses.

1 files changed, 50 insertions, 14 deletions

diff --git a/email/email.scm b/email/email.scm
index df69394..16838d9 100644
--- a/email/email.scm
+++ b/email/email.scm
@@ -124,14 +124,20 @@
 
 (define-printable-ascii-character-pattern ctext "(" ")" "\\")
 
-(define-peg-pattern comment none
-  (and "(" (* (and (? fws) ccontent)) ")"))
+(define-syntax-rule (define-comment-pattern name capture-type)
+  (define-peg-pattern name capture-type
+    (and (ignore "(") (* (and (? fws) ccontent)) (ignore ")"))))
+
+(define-comment-pattern comment none)
 
 (define-peg-pattern ccontent body
   (or ctext quoted-pair comment))
 
-(define-peg-pattern cfws body
-  (or (and (+ (and (? fws) comment)) (? fws)) fws))
+(define-syntax-rule (define-cfws-pattern name comment)
+  (define-peg-pattern name body
+    (or (and (+ (and (? fws) comment)) (? fws)) fws)))
+
+(define-cfws-pattern cfws comment)
 
 ;;; Atom
 
@@ -144,8 +150,11 @@
 (define-peg-pattern dot-atom-text body
   (and (+ atext) (* (and "." (+ atext)))))
 
-(define-peg-pattern dot-atom body
-  (and (? cfws) dot-atom-text (? cfws)))
+(define-syntax-rule (define-dot-atom-pattern name cfws)
+  (define-peg-pattern name body
+    (and (? cfws) dot-atom-text (? cfws))))
+
+(define-dot-atom-pattern dot-atom cfws)
 
 ;;; Quoted strings
 
@@ -247,11 +256,17 @@
 (define-peg-pattern domain-literal body
   (and (? cfws) "[" (* (and (? fws) dtext)) (? fws) "]" (? cfws)))
 
-(define-peg-pattern domain body
-  (or dot-atom domain-literal))
+(define-syntax-rule (define-domain-pattern name dot-atom)
+  (define-peg-pattern name body
+    (or dot-atom domain-literal)))
+
+(define-domain-pattern domain dot-atom)
+
+(define-syntax-rule (define-addr-spec-pattern name domain)
+  (define-peg-pattern name body
+    (and local-part "@" domain)))
 
-(define-peg-pattern addr-spec body
-  (and local-part "@" domain))
+(define-addr-spec-pattern addr-spec domain)
 
 (define-syntax-rule (define-angle-addr-pattern
                       name opening-bracket closing-bracket)
@@ -278,8 +293,20 @@
 (define-peg-pattern name-addr body
   (and (? display-name) unbracketed-angle-addr))
 
+;; In order to support emacs message mode parens style email
+;; addresses, we need to capture comments in address fields and
+;; process them as names. But, we need to ignore comments in other
+;; parts of the email. In order to facilitate this, we define a set of
+;; captured-* patterns which are used in address fields.
+
+(define-comment-pattern captured-comment all)
+(define-cfws-pattern captured-cfws captured-comment)
+(define-dot-atom-pattern captured-dot-atom captured-cfws)
+(define-domain-pattern captured-domain captured-dot-atom)
+(define-addr-spec-pattern captured-addr-spec captured-domain)
+
 (define-peg-pattern mailbox all
-  (or name-addr addr-spec))
+  (or name-addr captured-addr-spec))
 
 (define-peg-pattern mailbox-list all
   (and mailbox (* (and (ignore ",") mailbox))))
@@ -580,15 +607,24 @@ explained in RFC2045), and return that list."
                 (read-while port get-line-with-delimiter identity))))))
 
 (define (post-process-mailbox . args)
+  (define process-name
+    (compose decode-mime-encoded-word string-trim-both))
+
   (match args
     ;; name-addr email address
     (`(mailbox (display-name ,name) ,address)
-     `((name . ,(decode-mime-encoded-word
-                 (string-trim-both name)))
+     `((name . ,(process-name name))
        (address . ,(string-trim-both address))))
     ;; addr-spec email address
-    (`(mailbox ,address)
+    (`(mailbox ,(? string? address))
      `((address . ,(string-trim-both address))))
+    ;; emacs message mode parens style email address
+    (`(mailbox ,(? list? address-parts))
+     `((name . ,(match-let ((`((captured-comment ,name))
+                             (flatten-and-filter '(captured-comment) address-parts)))
+                  (process-name name)))
+       (address . ,(string-trim-both
+                    (string-join (drop-right address-parts 1) "")))))
     (_ (error "Failed to parse mailbox"))))
 
 (define (post-process-content-transfer-encoding _ value)