Changeset 18839 in project


Ignore:
Timestamp:
07/15/10 20:48:00 (11 years ago)
Author:
Ivan Raikov
Message:

converting internet-message to typeclass interface

Location:
release/4/internet-message/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/internet-message/trunk/internet-message.scm

    r17939 r18839  
    2323(module internet-message
    2424
    25         (comment fields body message parts addr-spec text ftext msg-id)
     25        (CoreABNF->InetMessage <InetMessage>)
    2626
    2727        (import scheme chicken data-structures srfi-1 srfi-14)
    2828
     29        (require-extension typeclass)
    2930        (require-library srfi-1 srfi-13 abnf abnf-consumers)
    3031        (import (prefix abnf abnf:)
    3132                (prefix abnf-consumers abnf:)
     33                (only abnf <CoreABNF> <Input> <Token> <CharLex> )
    3234                (only srfi-13 string-downcase)
    3335                )
    3436
     37
     38
     39(define-class <InetMessage> (<CoreABNF> A) 
     40  comment fields body message parts addr-spec text ftext msg-id)
    3541
    3642(define (char-list-titlecase x)
     
    5864;; and a parser for the body.
    5965
    60 (define (header s p) 
    61   (let ((ss (->string s)))
    62     (lambda (#!key (crlf abnf:crlf) (alist #f))
     66(define=> (header <CoreABNF>)
     67  (lambda (s p) 
     68    (let ((ss (->string s)))
     69      (lambda (#!key (crlf crlf) (alist #f))
    6370        (if alist
    6471            (let ((value (abnf:bind (consumed-objects-lift-any)
     
    7178            (abnf:bind (consumed-objects-lift-any)
    7279                       (abnf:concatenation
    73                         (bind-consumed->tsymbol (abnf:lit ss))
    74                         (abnf:drop-consumed (abnf:char #\:))
     80                        (bind-consumed->tsymbol (lit ss))
     81                        (abnf:drop-consumed (char #\:))
    7582                        p
    7683                        (abnf:drop-consumed crlf)
    7784                        ))
    78             ))))
     85            )))))
    7986
    8087
     
    8491;; Matches any US-ASCII character except for nul \r \n
    8592
    86 (define text (abnf:set (char-set-difference
    87                         char-set:ascii
    88                         (char-set (integer->char 0)
    89                                   (integer->char 10)
    90                                   (integer->char 13) ))))
     93(define=> (text <CoreABNF>)
     94  (set (char-set-difference
     95        char-set:ascii
     96        (char-set (integer->char 0)
     97                  (integer->char 10)
     98                  (integer->char 13) ))))
    9199
    92100
    93101;; Folding white space and comments (section 3.2.3)
    94102
    95 (define fws
     103(define=> (fws <CoreABNF>)
    96104  (abnf:concatenation
    97105   (abnf:optional-sequence
    98106    (abnf:concatenation
    99      (abnf:repetition abnf:wsp)
     107     (abnf:repetition wsp)
    100108     (abnf:drop-consumed
    101       (abnf:alternatives abnf:crlf abnf:lf abnf:cr))))
    102    (abnf:repetition1 abnf:wsp)))
    103 
    104 (define (between-fws-drop p)
     109      (abnf:alternatives crlf lf cr))))
     110   (abnf:repetition1 wsp)))
     111
     112(define (between-fws-drop p fws)
    105113  (abnf:concatenation
    106114   (abnf:drop-consumed (abnf:optional-sequence fws)) p
    107115   (abnf:drop-consumed (abnf:optional-sequence fws))))
    108116                             
    109 
    110117;; helper macro for mutually-recursive parser definitions
    111118
     
    117124;; Matches any non-whitespace, non-control character except for ( ) and \
    118125
    119 (define ctext  (abnf:set (char-set-difference char-set:graphic (char-set #\( #\) #\\))))
     126(define=> (ctext <CoreABNF>)
     127  (set (char-set-difference char-set:graphic (char-set #\( #\) #\\))))
    120128
    121129;; Matches comments. That is any combination of ctext, quoted pairs,
    122130;; and fws between brackets. Comments may nest.
    123131
    124 (define ccontent (vac (abnf:alternatives ctext abnf:quoted-pair comment)))
    125 
    126 (define comment (abnf:concatenation
    127                  (abnf:char #\( )
    128                  (abnf:longest
    129                   (abnf:repetition
    130                    (abnf:concatenation
    131                     (abnf:optional-sequence fws)
    132                     ccontent
    133                     )))
    134                  (abnf:optional-sequence fws)
    135                  (abnf:char #\))
    136                  ))
     132(define=> (ccontent <CoreABNF>)
     133  (lambda (comment ctext)
     134    (abnf:alternatives ctext quoted-pair comment)))
     135
     136(define=> (comment <CoreABNF>)
     137  (lambda (ccontent fws)
     138    (abnf:concatenation
     139     (char #\( )
     140     (abnf:longest
     141      (abnf:repetition
     142       (abnf:concatenation
     143        (abnf:optional-sequence fws)
     144        ccontent
     145        )))
     146     (abnf:optional-sequence fws)
     147     (char #\))
     148     )))
    137149
    138150;; Matches any combination of fws and comments
    139151
    140 (define cfws (abnf:alternatives
    141               (abnf:concatenation
    142                (abnf:repetition1
    143                 (abnf:concatenation
    144                  (abnf:optional-sequence fws)
    145                  (abnf:drop-consumed comment)))
    146                (abnf:optional-sequence fws))
    147               fws))
     152(define=> (cfws <CoreABNF>)
     153  (lambda (comment fws)
     154    (abnf:alternatives
     155     (abnf:concatenation
     156      (abnf:repetition1
     157       (abnf:concatenation
     158        (abnf:optional-sequence fws)
     159        (abnf:drop-consumed comment)))
     160      (abnf:optional-sequence fws))
     161     fws)))
    148162                 
    149163
    150164;;  A combinator for sequences (optional cfws) p (optional cfws)
    151165
    152 (define (between-cfws p)
     166(define (between-cfws p cfws)
    153167  (abnf:concatenation
    154168   (abnf:optional-sequence cfws) p
    155169   (abnf:optional-sequence cfws) ))
    156170                             
    157 (define (between-cfws-drop p)
     171(define (between-cfws-drop p cfws)
    158172  (abnf:concatenation
    159173   (abnf:drop-consumed (abnf:optional-sequence cfws)) p
     
    166180;; specials, or space. atom and dot-atom are made up of this.
    167181
    168 (define atext (abnf:alternatives
    169                abnf:alpha
    170                abnf:decimal
    171                (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))
     182(define=> (atext <CoreABNF>)
     183  (abnf:alternatives
     184   alpha
     185   decimal
     186   (set-from-string "!#$%&'*+-/=?^_`{|}~")))
    172187
    173188;; Matches one or more atext characters and skip any preceeding or
    174189;; trailing cfws
    175190
    176 (define atom (abnf:bind-consumed->string (between-cfws (abnf:repetition1 atext))))
     191(define=> (atom <CoreABNF>)
     192  (lambda (atext cfws)
     193    (abnf:bind-consumed->string
     194     (between-cfws (abnf:repetition1 atext) cfws))))
     195
    177196
    178197;; Matches two or more atext elements interspersed by dots.
    179198
    180 (define dot-atom-text (abnf:concatenation
    181                        (abnf:repetition1 atext)
    182                        (abnf:repetition
    183                         (abnf:concatenation
    184                          (abnf:char #\.)
    185                          (abnf:repetition1 atext)
    186                          ))))
     199(define=> (dot-atom-text <CoreABNF>)
     200  (lambda (atext)
     201    (abnf:concatenation
     202     (abnf:repetition1 atext)
     203     (abnf:repetition
     204      (abnf:concatenation
     205       (char #\.)
     206       (abnf:repetition1 atext)
     207       )))))
    187208
    188209;; Matches dot-atom-text and skips any preceeding or trailing cfws.
    189210
    190 (define dot-atom (abnf:bind-consumed->string (between-cfws dot-atom-text)))
     211(define=> (dot-atom <CoreABNF>)
     212  (lambda (dot-atom-text cfws)
     213    (abnf:bind-consumed->string
     214     (between-cfws dot-atom-text cfws))))
    191215
    192216;; Quoted strings (section 3.2.4)
     
    196220
    197221(define char-set:quoted (char-set-difference char-set:printing (char-set #\\ #\")))
    198 (define qtext (abnf:set char-set:quoted))
     222(define=> (qtext <CoreABNF>) (set char-set:quoted))
    199223
    200224
    201225;; Matches either qtext or quoted-pair
    202226
    203 (define qcontent (abnf:repetition1
    204                   (abnf:alternatives
    205                    qtext abnf:quoted-pair)))
     227(define=> (qcontent  <CoreABNF>)
     228  (lambda (qtext)
     229    (abnf:repetition1
     230     (abnf:alternatives
     231      qtext quoted-pair))))
    206232
    207233;; Matches any number of qcontent between double quotes.
    208234
    209 (define quoted-string
    210   (abnf:bind-consumed->string
    211    (between-cfws
    212     (abnf:concatenation
    213      (abnf:drop-consumed abnf:dquote)
    214      (abnf:repetition
     235(define=> (quoted-string <CoreABNF>)
     236  (lambda (qcontent fws cfws)
     237    (abnf:bind-consumed->string
     238     (between-cfws
    215239      (abnf:concatenation
     240       (abnf:drop-consumed dquote)
     241       (abnf:repetition
     242        (abnf:concatenation
     243         (abnf:optional-sequence fws)
     244         qcontent))
    216245       (abnf:optional-sequence fws)
    217        qcontent))
    218      (abnf:optional-sequence fws)
    219      (abnf:drop-consumed abnf:dquote)))))
     246       (abnf:drop-consumed dquote))
     247      cfws)
     248      )))
    220249
    221250;; Miscellaneous tokens (section 3.2.5)
     
    223252;;; Matches either atom or quoted-string
    224253
    225 (define word (abnf:alternatives atom quoted-string))
    226 
     254(define=> (word <CoreABNF>)
     255  (lambda (atom quoted-string)
     256    (abnf:alternatives atom quoted-string)))
     257 
    227258;; Matches either one or more word elements
    228259
    229 (define phrase
    230   (abnf:bind-consumed-strings->list (abnf:repetition1 word)))
     260(define=> (phrase  <CoreABNF>)
     261  (lambda (word)
     262    (abnf:bind-consumed-strings->list
     263     (abnf:repetition1 word))))
    231264
    232265
     
    235268;; Unstructured text is used in free text fields such as subject.
    236269
    237 (define unstructured
    238   (abnf:bind-consumed->string
    239    (abnf:concatenation
    240     (abnf:repetition
     270(define=> (unstructured <CoreABNF>)
     271  (lambda (fws)
     272    (abnf:bind-consumed->string
    241273     (abnf:concatenation
    242       (abnf:optional-sequence fws)
    243       abnf:vchar))
    244     (abnf:repetition abnf:wsp))))
     274      (abnf:repetition
     275       (abnf:concatenation
     276        (abnf:optional-sequence fws)
     277        vchar))
     278      (abnf:repetition wsp)))))
    245279
    246280;; Date and Time Specification (section 3.3)
     
    261295;; Matches the abbreviated weekday names
    262296
    263 (define day-name
     297(define=> (day-name <CoreABNF>)
    264298  (abnf:alternatives
    265    (abnf:lit "Mon")
    266    (abnf:lit "Tue")
    267    (abnf:lit "Wed")
    268    (abnf:lit "Thu")
    269    (abnf:lit "Fri")
    270    (abnf:lit "Sat")
    271    (abnf:lit "Sun")))
     299   (lit "Mon")
     300   (lit "Tue")
     301   (lit "Wed")
     302   (lit "Thu")
     303   (lit "Fri")
     304   (lit "Sat")
     305   (lit "Sun")))
    272306
    273307;; Matches a day-name, optionally wrapped in folding whitespace
    274308
    275 (define day-of-week
    276   (abnf:bind-consumed-strings->list
    277    'day-of-week
    278    (between-fws-drop
    279     (abnf:bind-consumed->string day-name))))
     309(define=> (day-of-week  <CoreABNF>)
     310  (lambda (day-name fws)
     311    (abnf:bind-consumed-strings->list
     312     'day-of-week
     313     (between-fws-drop
     314      (abnf:bind-consumed->string day-name)
     315      fws))))
    280316
    281317
    282318;; Matches a four digit decimal number
    283319
    284 (define year
    285   (between-fws-drop
    286    (abnf:bind-consumed->string (abnf:repetition-n 4 abnf:decimal))))
     320(define=> (year  <CoreABNF>)
     321  (lambda (fws)
     322    (between-fws-drop
     323     (abnf:bind-consumed->string (abnf:repetition-n 4 decimal))
     324     fws)))
    287325
    288326;; Matches the abbreviated month names
    289327
    290328
    291 (define month-name (abnf:alternatives
    292                     (abnf:lit "Jan")
    293                     (abnf:lit "Feb")
    294                     (abnf:lit "Mar")
    295                     (abnf:lit "Apr")
    296                     (abnf:lit "May")
    297                     (abnf:lit "Jun")
    298                     (abnf:lit "Jul")
    299                     (abnf:lit "Aug")
    300                     (abnf:lit "Sep")
    301                     (abnf:lit "Oct")
    302                     (abnf:lit "Nov")
    303                     (abnf:lit "Dec")))
     329(define=> (month-name <CoreABNF>)
     330  (abnf:alternatives
     331   (lit "Jan")
     332   (lit "Feb")
     333   (lit "Mar")
     334   (lit "Apr")
     335   (lit "May")
     336   (lit "Jun")
     337   (lit "Jul")
     338   (lit "Aug")
     339   (lit "Sep")
     340   (lit "Oct")
     341   (lit "Nov")
     342   (lit "Dec")))
    304343
    305344;; Matches a month-name, optionally wrapped in folding whitespace
    306345
    307 (define month (between-fws-drop (abnf:bind-consumed->string month-name)))
     346(define=> (month <CoreABNF>)
     347  (lambda (month-name fws)
     348    (between-fws-drop (abnf:bind-consumed->string month-name)
     349                      fws)))
    308350
    309351
    310352;; Matches a one or two digit number
    311353
    312 (define day (abnf:concatenation
    313              (abnf:drop-consumed (abnf:optional-sequence fws))
    314              (abnf:alternatives
    315               (abnf:bind-consumed->string (abnf:variable-repetition 1 2 abnf:decimal))
    316               (abnf:drop-consumed fws))))
     354(define=> (day <CoreABNF>)
     355  (lambda (fws)
     356    (abnf:concatenation
     357     (abnf:drop-consumed (abnf:optional-sequence fws))
     358     (abnf:alternatives
     359      (abnf:bind-consumed->string (abnf:variable-repetition 1 2 decimal))
     360      (abnf:drop-consumed fws)))))
    317361
    318362;; Matches a date of the form dd:mm:yyyy
    319 (define date
    320   (abnf:bind-consumed-strings->list 'date
    321     (abnf:concatenation day month year)))
     363(define=> (date  <CoreABNF>)
     364  (lambda (day month year)
     365    (abnf:bind-consumed-strings->list 'date
     366      (abnf:concatenation day month year))))
    322367
    323368;; Matches a two-digit number
    324369
    325 (define hour      (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
    326 (define minute    (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
    327 (define isecond   (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
     370(define=> (hour <CoreABNF>)
     371  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
     372(define=> (minute <CoreABNF>)
     373  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
     374(define=> (isecond <CoreABNF>)
     375  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
     376
    328377
    329378;; Matches a time-of-day specification of hh:mm or hh:mm:ss.
    330379
    331 (define time-of-day (abnf:concatenation
    332                      hour (abnf:drop-consumed (abnf:char #\:))
    333                      minute (abnf:optional-sequence
    334                              (abnf:concatenation (abnf:drop-consumed (abnf:char #\:))
    335                                                  isecond))))
     380(define=> (time-of-day <CoreABNF>)
     381  (lambda (hour minute isecond)
     382    (abnf:concatenation
     383     hour (abnf:drop-consumed (char #\:))
     384     minute (abnf:optional-sequence
     385             (abnf:concatenation (abnf:drop-consumed (char #\:))
     386                                 isecond)))))
    336387
    337388;; Matches a timezone specification of the form
    338389;; +hhmm or -hhmm
    339390
    340 (define zone (abnf:concatenation
    341               (abnf:drop-consumed fws)
    342               (abnf:bind-consumed->string (abnf:alternatives (abnf:char #\-) (abnf:char #\+)))
    343               hour minute))
     391(define=> (zone <CoreABNF>)
     392  (lambda (hour minute fws)
     393    (abnf:concatenation
     394     (abnf:drop-consumed fws)
     395     (abnf:bind-consumed->string (abnf:alternatives (char #\-) (char #\+)))
     396     hour minute)))
    344397
    345398;; Matches a time-of-day specification followed by a zone.
    346399
    347 (define itime
    348   (abnf:bind-consumed-strings->list 'time
    349     (abnf:concatenation time-of-day zone)))
    350 
    351 (define date-time (abnf:concatenation
    352                    (abnf:optional-sequence
    353                     (abnf:concatenation
    354                      day-of-week
    355                      (abnf:drop-consumed (abnf:char #\,))))
    356                    date
    357                    itime
    358                    (abnf:drop-consumed (abnf:optional-sequence cfws))))
     400(define=> (itime  <CoreABNF>)
     401  (lambda (time-of-day zone)
     402    (abnf:bind-consumed-strings->list 'time
     403      (abnf:concatenation time-of-day zone))))
     404
     405(define=> (date-time <CoreABNF>)
     406  (lambda (day-of-week date itime cfws)
     407    (abnf:concatenation
     408     (abnf:optional-sequence
     409      (abnf:concatenation
     410       day-of-week
     411       (abnf:drop-consumed (char #\,))))
     412     date
     413     itime
     414     (abnf:drop-consumed (abnf:optional-sequence cfws)))))
    359415
    360416
     
    365421;; a dot-atom or a quoted-string.
    366422
    367 (define local-part (abnf:alternatives dot-atom quoted-string))
     423(define=> (local-part <CoreABNF>)
     424  (lambda (dot-atom quoted-string)
     425    (abnf:alternatives dot-atom quoted-string)))
    368426
    369427
    370428;; Parses and returns any ASCII characters except [ ] and \
    371429
    372 (define dtext  (abnf:set (char-set-difference char-set:printing (char-set #\[ #\] #\\))))
     430(define=> (dtext <CoreABNF>)
     431  (set (char-set-difference char-set:printing (char-set #\[ #\] #\\))))
    373432
    374433
     
    376435;; amount of dcontent, followed by a terminating ] character.
    377436
    378 (define domain-literal (between-cfws
    379                          (abnf:concatenation
    380                           (abnf:drop-consumed (abnf:char #\[))
    381                           (abnf:bind-consumed->string
    382                            (abnf:repetition
    383                             (abnf:concatenation
    384                              (abnf:drop-consumed (abnf:optional-sequence fws))
    385                              dtext)))
    386                           (abnf:drop-consumed (abnf:optional-sequence fws))
    387                           (abnf:drop-consumed (abnf:char #\]))
    388                           )))
     437(define=> (domain-literal <CoreABNF>)
     438  (lambda (dtext cfws )
     439    (between-cfws
     440     (abnf:concatenation
     441      (abnf:drop-consumed (char #\[))
     442      (abnf:bind-consumed->string
     443       (abnf:repetition
     444        (abnf:concatenation
     445         (abnf:drop-consumed (abnf:optional-sequence fws))
     446         dtext)))
     447      (abnf:drop-consumed (abnf:optional-sequence fws))
     448      (abnf:drop-consumed (char #\])))
     449     cfws)))
    389450
    390451;; Parses and returns a domain part of an addr-spec. That is either
    391452;; a dot-atom or a domain-literal.
    392453
    393 (define domain  (abnf:alternatives dot-atom domain-literal))
     454(define=> (domain <CoreABNF>)
     455  (lambda (dot-atom domain-literal)
     456    (abnf:alternatives dot-atom domain-literal)))
    394457
    395458
     
    399462;; by an \ character, followed by a domain.
    400463
    401 (define addr-spec
    402   (abnf:concatenation
    403    (abnf:bind-consumed-strings->list 'local-part local-part)
    404    (abnf:drop-consumed (abnf:char #\@))
    405    (abnf:bind-consumed-strings->list 'domain domain)))
     464(define=> (addr-spec <CoreABNF>)
     465  (lambda (local-part domain)
     466    (abnf:concatenation
     467     (abnf:bind-consumed-strings->list 'local-part local-part)
     468     (abnf:drop-consumed (char #\@))
     469     (abnf:bind-consumed-strings->list 'domain domain))))
    406470
    407471;; Parses an angle-addr
    408472
    409 (define angle-addr
    410   (between-cfws-drop
    411    (abnf:concatenation
    412     (abnf:drop-consumed (abnf:char #\<))
    413     addr-spec
    414     (abnf:drop-consumed (abnf:char #\>))
    415     )))
     473(define=> (angle-addr <CoreABNF>)
     474  (lambda (addr-spec cfws)
     475    (between-cfws-drop
     476     (abnf:concatenation
     477      (abnf:drop-consumed (char #\<))
     478      addr-spec
     479      (abnf:drop-consumed (char #\>))
     480      )
     481    cfws)))
    416482
    417483
    418484;; Parses and returns a phrase.
    419 (define display-name  (abnf:bind-consumed-pairs->list 'display-name phrase))
     485(define=> (display-name <CoreABNF>)
     486  (lambda (phrase)
     487    (abnf:bind-consumed-pairs->list 'display-name phrase)))
    420488
    421489;; Matches an angle-addr, optionally prefaced with a display-name
    422490
    423 (define name-addr
    424   (abnf:concatenation
    425    (abnf:optional-sequence display-name)
    426    angle-addr))
     491(define=> (name-addr <CoreABNF>)
     492  (lambda (display-name angle-addr)
     493    (abnf:concatenation
     494     (abnf:optional-sequence display-name)
     495     angle-addr)))
    427496
    428497;; Matches a name-addr or an addr-spec and returns the address.
    429498
    430 (define mailbox
    431   (abnf:bind-consumed-pairs->list 'mailbox
    432    (abnf:alternatives name-addr addr-spec)))
     499(define=> (mailbox  <CoreABNF>)
     500  (lambda (name-addr addr-spec)
     501    (abnf:bind-consumed-pairs->list 'mailbox
     502     (abnf:alternatives name-addr addr-spec))))
    433503
    434504;; Parses a list of mailbox addresses, every two addresses being
    435505;; separated by a comma, and returns the list of found address(es).
    436506
    437 (define mailbox-list
    438   (abnf:bind-consumed-pairs->list 'mailbox-list
    439    (abnf:concatenation
    440     mailbox
    441     (abnf:repetition
     507(define=> (mailbox-list <CoreABNF>)
     508  (lambda (mailbox)
     509    (abnf:bind-consumed-pairs->list 'mailbox-list
    442510     (abnf:concatenation
    443       (abnf:drop-consumed (abnf:char #\,))
    444       mailbox)))))
     511      mailbox
     512      (abnf:repetition
     513       (abnf:concatenation
     514        (abnf:drop-consumed (char #\,))
     515        mailbox))))))
    445516
    446517
     
    452523;;    my group: user1@example.org, user2@example.org;
    453524
    454 (define group (vac (abnf:bind-consumed-pairs->list 'group
    455                    (abnf:concatenation
    456                     display-name
    457                     (abnf:drop-consumed (abnf:char #\:))
    458                     (abnf:optional-sequence group-list)
    459                     (abnf:drop-consumed (abnf:char #\;))
    460                     (abnf:drop-consumed (abnf:optional-sequence cfws))))))
     525(define=> (group <CoreABNF>)
     526  (lambda (display-name group-list cfws)
     527    (abnf:bind-consumed-pairs->list 'group
     528      (abnf:concatenation
     529       display-name
     530       (abnf:drop-consumed (char #\:))
     531       (abnf:optional-sequence group-list)
     532       (abnf:drop-consumed (char #\;))
     533       (abnf:drop-consumed (abnf:optional-sequence cfws))))))
    461534 
    462 (define group-list (abnf:alternatives
    463                     mailbox-list
    464                     (abnf:drop-consumed cfws)))
     535(define=> (group-list <CoreABNF>)
     536  (lambda (mailbox-list cfws)
     537    (abnf:alternatives
     538     mailbox-list
     539     (abnf:drop-consumed cfws))))
    465540
    466541;; Matches a single mailbox or an address group
    467542
    468 (define address (abnf:alternatives mailbox group))
     543(define=> (address <CoreABNF>)
     544  (lambda (mailbox group)
     545    (abnf:alternatives mailbox group)))
    469546
    470547;; Parses a list of address addresses, every two addresses being
    471548;; separated by a comma, and returns the list of found address(es).
    472549
    473 (define address-list (abnf:concatenation
    474                       address
    475                       (abnf:repetition
    476                        (abnf:concatenation
    477                         (abnf:drop-consumed (abnf:char #\,))
    478                         address))))
     550(define=> (address-list <CoreABNF>)
     551  (lambda (address)
     552    (abnf:concatenation
     553     address
     554     (abnf:repetition
     555      (abnf:concatenation
     556       (abnf:drop-consumed (char #\,))
     557       address)))))
    479558
    480559;;  Overall message syntax (section 3.5)
     
    484563;; divided into separate lines by crlf.
    485564
    486 (define body (abnf:repetition
    487               (abnf:concatenation
    488                (abnf:repetition
    489                  (abnf:concatenation
    490                   (abnf:bind-consumed->string
    491                    (abnf:repetition text))
    492                   (abnf:drop-consumed
    493                    (abnf:repetition abnf:crlf))))
    494                (abnf:bind-consumed->string
    495                 (abnf:repetition text)))))
     565(define=> (body <CoreABNF>)
     566  (lambda (text)
     567    (abnf:repetition
     568     (abnf:concatenation
     569      (abnf:repetition
     570       (abnf:concatenation
     571        (abnf:bind-consumed->string
     572         (abnf:repetition text))
     573        (abnf:drop-consumed
     574         (abnf:repetition crlf))))
     575      (abnf:bind-consumed->string
     576       (abnf:repetition text))))))
    496577
    497578;; Field definitions (section 3.6)
     
    502583;; (year month dom hour min sec tz dow)
    503584
    504 (define orig-date  (header "Date" date-time))
     585(define (orig-date header date-time)  (header "Date" date-time))
    505586
    506587;; Originator fields (section 3.6.2)
     
    509590;; contained in it.
    510591
    511 (define from      (header "From" mailbox-list))
     592(define (from header mailbox-list)      (header "From" mailbox-list))
    512593
    513594;; Parses a Sender: header and returns the mailbox address contained in
    514595;; it.
    515596
    516 (define sender    (header "Sender" mailbox))
     597(define (sender header mailbox)    (header "Sender" mailbox))
    517598
    518599;; Parses a Reply-To: header and returns the address-list address(es)
    519600;; contained in it.
    520601
    521 (define reply-to  (header "Reply-To" address-list))
     602(define (reply-to header address-list)  (header "Reply-To" address-list))
    522603
    523604;; Destination address fields (section 3.6.3)
     
    526607;; contained in it.
    527608
    528 (define to        (header "To" address-list))
     609(define (to header address-list)        (header "To" address-list))
    529610
    530611;; Parses a Cc: header and returns the address-list address(es)
    531612;; contained in it.
    532613
    533 (define cc        (header "Cc" address-list))
     614(define (cc header address-list)        (header "Cc" address-list))
    534615
    535616;; Parses a Bcc: header and returns the address-list address(es)
    536617;; contained in it.
    537618
    538 (define bcc       (header "Bcc" (abnf:optional-sequence
    539                                  (abnf:alternatives
    540                                   address-list
    541                                   (abnf:drop-consumed cfws)))))
     619(define (bcc header address-list cfws)
     620  (header "Bcc" (abnf:optional-sequence
     621                 (abnf:alternatives
     622                  address-list
     623                  (abnf:drop-consumed cfws)))))
    542624
    543625;; Identification fields (section 3.6.4)
     
    546628;; concatenated string. This makes up the id-right of a msg-id.
    547629
    548 (define no-fold-literal  (abnf:concatenation
    549                           (abnf:drop-consumed (abnf:char #\[))
    550                           (abnf:repetition dtext)
    551                           (abnf:drop-consumed (abnf:char #\]))))
     630(define=> (no-fold-literal <CoreABNF>)
     631  (lambda (dtext)
     632    (abnf:concatenation
     633     (abnf:drop-consumed (char #\[))
     634     (abnf:repetition dtext)
     635     (abnf:drop-consumed (char #\])))))
    552636
    553637;; Parses a left ID part of a msg-id. This is almost identical to
     
    555639;; about folding and whitespace.
    556640
    557 (define id-left   dot-atom-text )
     641(define (id-left dot-atom-text)   dot-atom-text )
    558642
    559643;; Parses a right ID part of a msg-id. This is almost identical to the
     
    561645;; and whitespace.
    562646
    563 (define id-right  (abnf:alternatives dot-atom-text no-fold-literal))
     647(define (id-right dot-atom-text no-fold-literal)
     648  (abnf:alternatives dot-atom-text no-fold-literal))
    564649
    565650;; Parses a message ID and returns it. A message ID is almost identical
     
    567652;; whitespace.
    568653
    569 (define msg-id
    570   (abnf:bind-consumed-strings->list 'message-id
    571     (between-cfws-drop
    572      (abnf:concatenation
    573       (abnf:drop-consumed (abnf:char #\<))
    574       (abnf:bind-consumed->string id-left)
    575       (abnf:drop-consumed (abnf:char #\@))
    576       (abnf:bind-consumed->string id-right)
    577       (abnf:drop-consumed (abnf:char #\>))
    578       ))))
     654(define=> (msg-id <CoreABNF>)
     655  (lambda (id-left id-right cfws)
     656    (abnf:bind-consumed-strings->list 'message-id
     657      (between-cfws-drop
     658       (abnf:concatenation
     659        (abnf:drop-consumed (char #\<))
     660        (abnf:bind-consumed->string id-left)
     661        (abnf:drop-consumed (char #\@))
     662        (abnf:bind-consumed->string id-right)
     663        (abnf:drop-consumed (char #\>))
     664        )
     665       cfws))))
    579666
    580667
     
    582669;; contained in it.
    583670
    584 (define in-reply-to (header "In-Reply-To" (abnf:repetition1 msg-id)))
     671(define (in-reply-to header msg-id) (header "In-Reply-To" (abnf:repetition1 msg-id)))
    585672
    586673;; Parses a References: header and returns the list of msg-id's
    587674;; contained in it.
    588675
    589 (define references  (header "References"  (abnf:repetition1 msg-id)))
     676(define (references header msg-id)  (header "References"  (abnf:repetition1 msg-id)))
    590677
    591678;; Parses a Message-Id: header and returns the msg-id contained
    592679;; in it.
    593680
    594 (define message-id (header "Message-ID" msg-id))
     681(define (message-id header msg-id) (header "Message-ID" msg-id))
    595682                                           
    596683;; Informational fields (section 3.6.5)
     
    598685;; Parses a Subject: header and returns its contents verbatim.
    599686
    600 (define subject (header "Subject"  unstructured))
     687(define (subject header unstructured) (header "Subject"  unstructured))
    601688
    602689;; Parses a Comments: header and returns its contents verbatim.
    603690
    604 (define comments (header "Comments" unstructured))
     691(define (comments header unstructured) (header "Comments" unstructured))
    605692
    606693;; Parses a Keywords: header and returns the list of phrases
     
    608695;; returned by the phrase parser.
    609696
    610 (define keywords  (header "Keywords"
    611                            (abnf:concatenation
    612                             phrase
    613                             (abnf:repetition
    614                              (abnf:concatenation
    615                               (abnf:drop-consumed (abnf:char #\,))
    616                               phrase)))))
     697(define=> (kwd-list <CoreABNF>)
     698  (lambda (phrase)
     699    (abnf:concatenation
     700     phrase
     701     (abnf:repetition
     702      (abnf:concatenation
     703       (abnf:drop-consumed (char #\,))
     704       phrase)))))
     705
     706(define (keywords header kwd-list)  (header "Keywords" kwd-list))
     707                           
    617708
    618709;; Resent fields (section 3.6.6)
     
    621712;; CalendarTime
    622713
    623 (define resent-date (header "Resent-Date" date-time))
     714(define (resent-date header date-time) (header "Resent-Date" date-time))
    624715
    625716;; Parses a Resent-From: header and returns the mailbox-list address(es)
    626717;; contained in it.
    627718
    628 (define resent-from  (header "Resent-From" mailbox-list))
     719(define (resent-from header mailbox-list)  (header "Resent-From" mailbox-list))
    629720
    630721;; Parses a Resent-Sender: header and returns the mailbox-list
    631722;; address(es) contained in it.
    632723
    633 (define resent-sender (header "Resent-Sender" mailbox))
     724(define (resent-sender header mailbox) (header "Resent-Sender" mailbox))
    634725
    635726;; Parses a Resent-To header and returns the mailbox address contained
    636727;; in it.
    637728
    638 (define resent-to  (header "Resent-To" address-list))
     729(define (resent-to header address-list)  (header "Resent-To" address-list))
    639730
    640731;; Parses a Resent-Cc header and returns the address-list address(es)
    641732;; contained in it.
    642733
    643 (define resent-cc (header "Resent-Cc" address-list))
     734(define (resent-cc header address-list) (header "Resent-Cc" address-list))
    644735
    645736;; Parses a Resent-Bcc: header and returns the address-list
    646737;; address(es) contained in it. (This list may be empty.)
    647738
    648 (define resent-bcc   (header "Resent-Bcc"
    649                              (abnf:alternatives
    650                               address-list
    651                               (abnf:drop-consumed (abnf:optional-sequence cfws)))))
     739(define (resent-bcc header address-list cfws)
     740  (header "Resent-Bcc"
     741          (abnf:alternatives
     742           address-list
     743           (abnf:drop-consumed
     744            (abnf:optional-sequence cfws)))))
    652745
    653746
     
    655748;; in it.
    656749
    657 (define resent-msg-id  (header "Resent-Message-ID" msg-id))
     750(define (resent-msg-id header msg-id) 
     751  (header "Resent-Message-ID" msg-id))
    658752
    659753
     
    661755;; contained in it.
    662756
    663 (define resent-reply-to  (header "Resent-Reply-To" address-list))
     757(define (resent-reply-to header address-list)
     758  (header "Resent-Reply-To" address-list))
    664759
    665760
     
    667762
    668763                         
    669 (define path    (abnf:alternatives
    670                  angle-addr
    671                  (between-cfws-drop
    672                  (abnf:concatenation
    673                    (abnf:drop-consumed (abnf:char #\<))
    674                    (abnf:drop-consumed (abnf:optional-sequence cfws))
    675                    (abnf:drop-consumed (abnf:char #\>))))))
    676 
    677 (define return-path  (header "Return-Path" path))
    678 
    679 (define received-token
    680   (abnf:bind-consumed-strings->list
    681    'received-token
    682    (abnf:alternatives domain angle-addr addr-spec word)))
    683 
    684 (define received  (header "Received" 
    685                            (abnf:concatenation
    686                             (abnf:repetition received-token)
    687                             (abnf:drop-consumed (abnf:char #\;))
    688                             date-time)))
     764(define=> (path <CoreABNF>)
     765  (lambda (angle-addr cfws)
     766    (abnf:alternatives
     767     angle-addr
     768     (between-cfws-drop
     769      (abnf:concatenation
     770       (abnf:drop-consumed (char #\<))
     771       (abnf:drop-consumed (abnf:optional-sequence cfws))
     772       (abnf:drop-consumed (char #\>)))
     773      cfws))))
     774
     775(define (return-path header path)  (header "Return-Path" path))
     776
     777(define=> (received-token <CoreABNF>)
     778  (lambda (domain angle-addr addr-spec word)
     779    (abnf:bind-consumed-strings->list
     780     'received-token
     781     (abnf:alternatives domain angle-addr addr-spec word))))
     782
     783(define=> (received-token-list <CoreABNF>)
     784  (lambda (received-token date-time)
     785    (abnf:concatenation
     786     (abnf:repetition received-token)
     787     (abnf:drop-consumed (char #\;))
     788     date-time)))
     789 
     790
     791(define (received header received-token-list) 
     792  (header "Received"  received-token-list))
    689793
    690794
     
    694798;; characters, whitespace, and :
    695799
    696 (define ftext  (abnf:set (char-set-difference char-set:graphic
    697                                               (char-set #\:))))
     800(define=> (ftext <CoreABNF>)
     801  (set (char-set-difference char-set:graphic
     802                            (char-set #\:))))
    698803
    699804
     
    701806;; more ftext characters.
    702807
    703 (define field-name (bind-consumed->tsymbol (abnf:repetition1 ftext)))
     808(define=> (field-name <CoreABNF>)
     809  (lambda (ftext)
     810    (bind-consumed->tsymbol (abnf:repetition1 ftext))))
    704811
    705812;; Parses an arbitrary header field and returns a tuple containing the
     
    707814;; contain the terminating colon.
    708815
    709 (define optional-field 
    710   (lambda (#!key (crlf abnf:crlf) (alist #f))
    711     (abnf:bind (consumed-objects-lift-any)
    712                (abnf:concatenation
    713                 (if alist
    714                     abnf:pass
    715                     (abnf:concatenation
    716                      field-name
    717                      (abnf:drop-consumed (abnf:char #\:))))
    718                 unstructured
    719                 (abnf:drop-consumed crlf)))))
     816(define=> (optional-field  <CoreABNF>)
     817  (lambda (field-name unstructured)
     818    (lambda (#!key (crlf crlf) (alist #f))
     819      (abnf:bind (consumed-objects-lift-any)
     820                 (abnf:concatenation
     821                  (if alist
     822                      abnf:pass
     823                      (abnf:concatenation
     824                       field-name
     825                       (abnf:drop-consumed (char #\:))))
     826                  unstructured
     827                  (abnf:drop-consumed crlf))))))
    720828 
    721829;; This parser will parse an arbitrary number of header fields as
     
    729837;; possibly be accepted /should/ be.
    730838
    731 (define fields
    732   (lambda (#!key (crlf abnf:crlf))
    733     (abnf:longest
    734      (abnf:repetition
    735       (abnf:alternatives
    736        (from           crlf: crlf)
    737        (sender         crlf: crlf)
    738        (return-path    crlf: crlf)
    739        (reply-to       crlf: crlf)
    740        (to             crlf: crlf)
    741        (cc             crlf: crlf)
    742        (bcc            crlf: crlf)
    743        (message-id     crlf: crlf)
    744        (in-reply-to    crlf: crlf)
    745        (references     crlf: crlf)
    746        (subject        crlf: crlf)
    747        (comments       crlf: crlf)
    748        (keywords       crlf: crlf)
    749        (orig-date      crlf: crlf)
    750        (resent-date    crlf: crlf)
    751        (resent-from    crlf: crlf)
    752        (resent-sender  crlf: crlf)
    753        (resent-to      crlf: crlf)
    754        (resent-cc      crlf: crlf)
    755        (resent-bcc     crlf: crlf)
    756        (resent-msg-id    crlf: crlf)
    757        (resent-reply-to  crlf: crlf)
    758        (received         crlf: crlf)
    759        (optional-field   crlf: crlf))))
    760     ))
     839(define=> (fields <CoreABNF>)
     840  (lambda (from sender return-path reply-to to cc bcc message-id in-reply-to
     841           references subject comments keywords orig-date resent-date
     842           resent-from resent-sender resent-to resent-cc resent-bcc
     843           resent-msg-id resent-reply-to received optional-field)
     844    (lambda (#!key (crlf crlf))
     845      (abnf:longest
     846       (abnf:repetition
     847        (abnf:alternatives
     848         (from           crlf: crlf)
     849         (sender         crlf: crlf)
     850         (return-path    crlf: crlf)
     851         (reply-to       crlf: crlf)
     852         (to             crlf: crlf)
     853         (cc             crlf: crlf)
     854         (bcc            crlf: crlf)
     855         (message-id     crlf: crlf)
     856         (in-reply-to    crlf: crlf)
     857         (references     crlf: crlf)
     858         (subject        crlf: crlf)
     859         (comments       crlf: crlf)
     860         (keywords       crlf: crlf)
     861         (orig-date      crlf: crlf)
     862         (resent-date    crlf: crlf)
     863         (resent-from    crlf: crlf)
     864         (resent-sender  crlf: crlf)
     865         (resent-to      crlf: crlf)
     866         (resent-cc      crlf: crlf)
     867         (resent-bcc     crlf: crlf)
     868         (resent-msg-id    crlf: crlf)
     869         (resent-reply-to  crlf: crlf)
     870         (received         crlf: crlf)
     871         (optional-field   crlf: crlf))))
     872      )))
    761873
    762874
     
    764876;; the separate header fields and the message body.
    765877
    766 (define message
    767   (lambda (#!key (crlf abnf:crlf))
    768     (abnf:bind-consumed-pairs->list
    769      'message
    770      (abnf:concatenation
    771       (abnf:bind-consumed-pairs->list 'fields
    772        (fields crlf: crlf))
    773       (abnf:optional-sequence
     878(define=> (message <CoreABNF>)
     879  (lambda (fields body)
     880    (lambda (#!key (crlf crlf))
     881      (abnf:bind-consumed-pairs->list
     882       'message
    774883       (abnf:concatenation
    775         (abnf:drop-consumed crlf)
    776         (abnf:bind-consumed-strings->list 'body body)))
    777       ))))
     884        (abnf:bind-consumed-pairs->list 'fields
     885         (fields crlf: crlf))
     886        (abnf:optional-sequence
     887         (abnf:concatenation
     888          (abnf:drop-consumed crlf)
     889          (abnf:bind-consumed-strings->list 'body body)))
     890        )))))
    778891
    779892;; Given an alist of headers and a body, parses all header values and
     
    782895;; (PARSED-HEADERS PARSED-BODY)
    783896;;
    784 
    785 (define parts
    786   (lambda (#!key (crlf abnf:crlf))
    787     (let* ((header-parsers
    788            (map
    789             (lambda (p) (p alist: #t crlf: crlf))
    790             (list from
    791                   sender
    792                   return-path
    793                   reply-to
    794                   to
    795                   cc
    796                   bcc
    797                   message-id
    798                   in-reply-to
    799                   references
    800                   subject
    801                   comments
    802                   keywords
    803                   orig-date
    804                   resent-date
    805                   resent-from
    806                   resent-sender
    807                   resent-to
    808                   resent-cc
    809                   resent-bcc
    810                   resent-msg-id
    811                   resent-reply-to
    812                   received
    813                   optional-field)))
    814            (try-header
    815             (lambda (kv)
    816               (let loop ((fs header-parsers))
    817                 (if (null? fs) kv
    818                     (let ((kv1 (apply (car fs) kv)))
    819                       (or kv1 (loop (cdr fs)))))))))
    820       (lambda (unparsed-headers unparsed-body)
    821         (let ((parsed-headers (map try-header unparsed-headers))
    822               (parsed-body (body (unparsed-body))))
    823           (list parsed-headers parsed-body))))))
    824    
     897(define=> (parts <CoreABNF>)
     898  (lambda (from sender return-path reply-to to cc bcc message-id in-reply-to
     899           references subject comments keywords orig-date resent-date
     900           resent-from resent-sender resent-to resent-cc resent-bcc
     901           resent-msg-id resent-reply-to received optional-field)
     902    (lambda (#!key (crlf crlf))
     903      (let* (
     904             (header-parsers
     905              (map
     906               (lambda (p) (p alist: #t crlf: crlf))
     907               (list from
     908                     sender
     909                     return-path
     910                     reply-to
     911                     to
     912                     cc
     913                     bcc
     914                     message-id
     915                     in-reply-to
     916                     references
     917                     subject
     918                     comments
     919                     keywords
     920                     orig-date
     921                     resent-date
     922                     resent-from
     923                     resent-sender
     924                     resent-to
     925                     resent-cc
     926                     resent-bcc
     927                     resent-msg-id
     928                     resent-reply-to
     929                     received
     930                     optional-field)))
     931             (try-header
     932              (lambda (kv)
     933                (let loop ((fs header-parsers))
     934                  (if (null? fs) kv
     935                      (let ((kv1 (apply (car fs) kv)))
     936                        (or kv1 (loop (cdr fs)))))))))
     937        (lambda (unparsed-headers unparsed-body)
     938          (let ((parsed-headers (map try-header unparsed-headers))
     939                (parsed-body (body (unparsed-body))))
     940            (list parsed-headers parsed-body)))))))
     941
     942
     943(define (CoreABNF->InetMessage  A)
     944  (letrec  (
     945             ;; parsers for various header components
     946             (*header        (header A))
     947             (*fws           (fws A))
     948             (*text          (text A))
     949             (*ctext         (ctext A))
     950             (*ccontent      (vac ((ccontent A) *comment *ctext)))
     951             (*comment       ((comment A) *ccontent *fws))
     952             (*cfws          ((cfws A) *comment *fws))
     953
     954             (*ftext         (ftext A))
     955             (*atext         (atext A))
     956             (*atom          ((atom A) *atext *cfws))
     957             (*dot-atom-text ((dot-atom-text A) *atext))
     958             (*dot-atom      ((dot-atom A) *dot-atom-text *cfws))
     959
     960             (*qtext         (qtext A))
     961             (*qcontent      ((qcontent A) *qtext))
     962             (*quoted-string ((quoted-string A) *qcontent *fws *cfws))
     963             (*word          ((word A) *atom *quoted-string))
     964             (*phrase        ((phrase A) *word))
     965             (*display-name  ((display-name A) *phrase))
     966
     967             (*local-part     ((local-part A) *dot-atom *quoted-string))
     968             (*dtext          (dtext A))
     969             (*domain-literal ((domain-literal A) *dtext *cfws))
     970             (*domain         ((domain A) *dot-atom *domain-literal))
     971
     972             (*addr-spec     ((addr-spec A) *local-part *domain))
     973             (*angle-addr    ((angle-addr A) *addr-spec *cfws))
     974             (*name-addr     ((name-addr A) *display-name *angle-addr))
     975
     976             (*mailbox       ((mailbox  A) *name-addr *addr-spec))
     977             (*mailbox-list  ((mailbox-list A) *mailbox))
     978             (*group         (vac ((group A) *display-name *group-list *cfws)))
     979             (*group-list    ((group-list A) *mailbox-list *cfws))
     980             (*address       ((address A) *mailbox *group))
     981             (*address-list  ((address-list A) *address))
     982
     983             (*path          ((path A) *angle-addr *cfws))
     984
     985             (*no-fold-literal  ((no-fold-literal A) *dtext))
     986             (*id-left          (id-left *dot-atom-text))
     987             (*id-right         (id-right *dot-atom-text *no-fold-literal))
     988             (*msg-id           ((msg-id A) *id-left *id-right *cfws))
     989
     990             (*unstructured     ((unstructured A) *fws))
     991
     992             (*kwd-list         ((kwd-list A) *phrase))
     993             
     994             (*day-name         (day-name A))
     995             (*day-of-week      ((day-of-week A) *day-name *fws))
     996             (*year             ((year A) *fws))
     997             (*month-name       (month-name A))
     998             (*month            ((month A) *month-name *fws))
     999             (*day              ((day A) *fws))
     1000             (*date             ((date A) *day *month *year ))
     1001             (*hour             (hour A))
     1002             (*minute           (minute A))
     1003             (*isecond          (isecond A))
     1004             (*time-of-day      ((time-of-day A) *hour *minute *isecond))
     1005             (*zone             ((zone A) *hour *minute *fws))
     1006             (*itime            ((itime  A) *time-of-day *zone))
     1007             (*date-time        ((date-time A) *day-of-week *date *itime *cfws))
     1008
     1009             (*received-token   ((received-token A) *domain *angle-addr *addr-spec *word))
     1010             (*received-token-list ((received-token-list A) *received-token *date-time))
     1011             
     1012             (*field-name       ((field-name A) *ftext))
     1013             (*optional-field   ((optional-field A) *field-name *unstructured)))
     1014    (let* (
     1015
     1016
     1017             ;; header parsers
     1018           (from             (from *header *mailbox-list))
     1019           (sender           (sender *header *mailbox))
     1020           (return-path      (return-path *header *path))
     1021           (reply-to         (reply-to *header *address-list))
     1022           (to               (to *header *address-list))
     1023           (cc               (cc *header *address-list))
     1024           (bcc              (bcc *header *address-list *cfws))
     1025           (message-id       (message-id *header *msg-id))
     1026           (in-reply-to      (in-reply-to *header *msg-id))
     1027           (references       (references *header *msg-id))
     1028           (subject          (subject *header *unstructured))
     1029           (comments         (comments *header *unstructured))
     1030           (keywords         (keywords *header *kwd-list))
     1031           (orig-date        (orig-date *header *date-time))
     1032           (received         (received *header *received-token-list))
     1033           (resent-date      (resent-date *header *date-time))
     1034           (resent-from      (resent-from *header *mailbox-list))
     1035           (resent-sender    (resent-sender *header *mailbox))
     1036           (resent-to        (resent-to *header *address-list))
     1037           (resent-cc        (resent-cc *header *address-list))
     1038           (resent-bcc       (resent-bcc *header *address-list *cfws))
     1039           (resent-msg-id    (resent-msg-id *header *msg-id))
     1040           (resent-reply-to  (resent-reply-to *header *address-list))
     1041           
     1042           ;; parsers for various components of the message
     1043           
     1044           (fields          ((fields A)
     1045                             from sender return-path reply-to to cc bcc
     1046                             message-id in-reply-to  references subject
     1047                             comments keywords orig-date resent-date
     1048                             resent-from resent-sender resent-to
     1049                             resent-cc resent-bcc resent-msg-id
     1050                             resent-reply-to received *optional-field))
     1051           
     1052           (body            ((body A) *text))
     1053           
     1054           (message         ((message A) fields body))
     1055           
     1056           (parts           ((parts A)
     1057                             from sender return-path reply-to to cc bcc
     1058                             message-id in-reply-to references subject
     1059                             comments keywords orig-date resent-date
     1060                             resent-from resent-sender resent-to
     1061                             resent-cc resent-bcc resent-msg-id
     1062                             resent-reply-to received *optional-field))
     1063           )
     1064      (make-<InetMessage> A *comment fields body message parts *addr-spec *text *ftext *msg-id)
     1065      )))
     1066 
     1067
     1068 
    8251069)
  • release/4/internet-message/trunk/internet-message.setup

    r17939 r18839  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O2 -d0 -s internet-message.scm -j internet-message)
     6(required-extension-version 'abnf 3.0)
     7
     8(compile -O3 -d0 -s internet-message.scm -j internet-message)
    79(compile -s internet-message.import.scm)
    810
     
    1719
    1820  ;; Assoc list with properties for your extension:
    19   '((version 3.1)
     21  '((version 4.0)
    2022    (documentation "internet-message.html")
    2123    ))
  • release/4/internet-message/trunk/tests/run.scm

    r17239 r18839  
     1;; input stream based on character list
    12
    23(use srfi-1 srfi-13 srfi-14)
    3 
    4 (require-library abnf lexgen)
    5 (import (prefix abnf abnf:) (prefix lexgen lex:) )
    6 (require-extension internet-message test)
     4(use test typeclass internet-message)
     5
     6(require-library abnf)
     7(import (only abnf <CoreABNF>
     8              Token.CharLex->CoreABNF
     9               <Input> <Token> <CharLex>
     10              Input->Token Token->CharLex make-<Input>
     11              ))
     12
     13
     14(define char-list-<Input>
     15  (make-<Input> null? car cdr))
     16
     17(define char-list-<Token>
     18  (Input->Token char-list-<Input>))
     19
     20(define char-list-<CharLex>
     21  (Token->CharLex char-list-<Token>))
     22
     23(define char-list-<CoreABNF>
     24  (Token.CharLex->CoreABNF char-list-<Token>
     25                           char-list-<CharLex>))
     26
     27
     28(define char-list-<InetMessage>
     29  (CoreABNF->InetMessage char-list-<CoreABNF> ))
     30
     31(import-instance (<InetMessage> char-list-<InetMessage>))
    732
    833(define (string->input-stream s) `((() ,(string->list s))))
     
    1439(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
    1540(define (pr label) (lambda (s) (print label ": " s)))
    16 
    1741
    1842(define (parse-fields cont s)
     
    170194
    171195
    172 (test-group "comments"
     196;(test-group "comments"
    173197  (for-each (lambda (p)
    174198              (let ((inp (first p))
    175199                    (res (second p)))
    176                 (comment (lambda (s) (test (apply sprintf "~S -> ~S" p) res  (car s))) (string->input-stream inp))))
    177             comment-cases))
     200                (let ((is (string->input-stream inp)))
     201                  (comment (lambda (s) (test (apply sprintf "~S -> ~S" p) res  (car s))) is))))
     202            comment-cases)
     203;)
    178204
    179205(test-group "fields"
     
    181207              (let ((inp (first p))
    182208                    (res (second p)))
    183                 (parse-fields (lambda (s) (test (apply sprintf "~S -> ~S" p) res  s)) (string->input-stream inp))))
    184             fields-cases))
     209                (let ((is (string->input-stream inp)))
     210                  (parse-fields (lambda (s) (test (apply sprintf "~S -> ~S" p) res  s)) is))))
     211            fields-cases)
     212)
    185213
    186214(test-group "message"
Note: See TracChangeset for help on using the changeset viewer.