Changeset 15802 in project


Ignore:
Timestamp:
09/09/09 05:15:33 (10 years ago)
Author:
iraikov
Message:

created the abnf-consumers library

Location:
release/4
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/abnf/abnf.meta

    r14691 r15802  
    55 ; List here all the files that should be bundled as part of your egg. 
    66
    7  (files "abnf.setup" "abnf.scm" "abnf.html" )
     7 (files "abnf.setup" "abnf.scm" "abnf-consumers.scm" "abnf.html" )
    88
    99 ; Your egg's license:
  • release/4/abnf/abnf.scm

    r15127 r15802  
    33;;  Syntax Specifications: ABNF".
    44;;
     5;;  Copyright 2009 Ivan Raikov.
    56;;  Based on the Haskell Rfc2234 module by Peter Simons.
    67;;
     
    4950         quoted-pair quoted-string
    5051
    51          pass bind drop-consumed collect-chars longest memo
     52         pass bind drop-consumed longest memo
    5253         )
    5354
     
    114115      (p cont1 ss1))))
    115116
    116 (define (collect-chars . rest)
    117   (define (consumed-chars cs)
    118     (and (pair? cs)
    119          (let loop ((cs cs) (ax (list)))
    120            (cond ((null? cs)         (list ax))
    121                  ((char? (car cs))   (loop (cdr cs) (cons (car cs) ax)))
    122                  (else               (cons ax cs))))))
    123   (let-optionals rest ((kons #f))
    124     (let ((make (cond ((symbol? kons)     (lambda (x) `(,kons ,x)))
    125                       ((procedure? kons)  (lambda (x) (kons x)))
    126                       (else car))))
    127       (lambda (x)
    128         (let* ((x1   (consumed-chars x))
    129                (res  (and x1 (not (null? x1)) (cons (make (car x1)) (cdr x1)))))
    130           res)))))
    131 
    132117(define (memo p . rest)
    133118  (let-optionals rest ((reduce (lex:try <)))
  • release/4/abnf/abnf.setup

    r15127 r15802  
    77(compile -s abnf.import.scm)
    88
     9(compile -O -d2 -S -s abnf-consumers.scm -j abnf-consumers)
     10(compile -s abnf-consumers.import.scm)
     11
    912(install-extension
    1013
     
    1316
    1417  ;; Files to install for your extension:
    15   `(,(dynld-name "abnf") ,(dynld-name "abnf.import") )
    16  
     18  `(,(dynld-name "abnf") ,(dynld-name "abnf.import")
     19    ,(dynld-name "abnf-consumers") ,(dynld-name "abnf-consumers.import")
     20    )
    1721
    1822  ;; Assoc list with properties for your extension:
    19   '((version 2.2)
     23  '((version 2.3)
    2024    (documentation "abnf.html")
    2125    ))
  • release/4/internet-message/trunk/internet-message.scm

    r15071 r15802  
    4343        (import scheme chicken data-structures srfi-1 srfi-14)
    4444
    45         (require-library srfi-1 abnf)
    46         (import (prefix abnf abnf:) )
    47 
    48 ;; construct strings from consumed chars
    49 (define scollect (abnf:collect-chars list->string))
    50 
    51 (define (trim-ws-char-list cs)
    52   (let* ((cs1 (let loop ((cs cs))
    53                (cond ((null? cs) (reverse cs))
    54                      ((char-set-contains? char-set:whitespace (car cs))
    55                       (loop (cdr cs)))
    56                      (else (reverse cs)))))
    57          (cs2  (let loop ((cs cs1))
    58                (cond ((null? cs) (reverse cs))
    59                      ((char-set-contains? char-set:whitespace (car cs))
    60                       (loop (cdr cs)))
    61                      (else (reverse cs))))))
    62     cs2))
    63    
    64 
    65 ;; construct symbols from consumed chars; trailing and preceding white
    66 ;; space is stripped
    67 (define sscollect (abnf:collect-chars (compose string->symbol list->string trim-ws-char-list)))
     45        (require-library srfi-1 abnf abnf-consumers)
     46        (import (prefix abnf abnf:)
     47                (prefix abnf-consumers abnf:)
     48                )
    6849
    6950(define (char-list-titlecase x)
     
    7152
    7253;; construct symbols from consumed chars
    73 (define tsscollect (abnf:collect-chars (compose string->symbol list->string char-list-titlecase trim-ws-char-list)))
    74 
    75 ;; collects all consumed objects of type obj?
    76 (define (consumed-objects obj?)
    77   (lambda (cs)
    78     (and (pair? cs)
    79          (let loop ((cs cs) (ax (list)))
    80            (cond ((null? cs)   (list ax ))
    81                  ((obj? (car cs))
    82                   (loop (cdr cs) (cons (car cs) ax)))
    83                  (else (cons ax cs)))))))
    84 
    85 ;; construct lists from consumed objects
    86 (define (lcollect obj?)
    87   (let ((get-consumed (consumed-objects obj?)))
    88     (lambda rest
    89       (let-optionals rest ((kons identity))
    90         (let ((make (if (procedure? kons) kons (lambda (x) `(,kons . ,x)))))
    91           (lambda (x)
    92             (let ((x1 (get-consumed x)))
    93               (and x1 (pair? (car x1)) (cons (make (car x1)) (cdr x1))))))))))
    94 
    95 
    96 ;; shortcut for (abnf:bind scollect (abnf:longest ... ))
    97 (define-syntax consumed->string
     54(define consumed-chars->tsymbol
     55  (abnf:consumed-chars->list
     56   (compose string->symbol
     57            list->string
     58            char-list-titlecase
     59            abnf:trim-ws-char-list)))
     60
     61;; shortcut for (abnf:bind consumed-chars->tsymbol (abnf:longest ... ))
     62(define-syntax bind-consumed->tsymbol
    9863  (syntax-rules ()
    99     ((_ p)    (abnf:bind scollect (abnf:longest p)))
     64    ((_ p)    (abnf:bind consumed-chars->tsymbol (abnf:longest p)))
    10065    ))
    10166
    102 ;; shortcut for (abnf:bind sscollect (abnf:longest ... ))
    103 (define-syntax consumed->symbol
    104   (syntax-rules ()
    105     ((_ p)    (abnf:bind sscollect (abnf:longest p)))
    106     ))
    107 
    108 ;; shortcut for (abnf:bind tsscollect (abnf:longest ... ))
    109 (define-syntax consumed->tsymbol
    110   (syntax-rules ()
    111     ((_ p)    (abnf:bind tsscollect (abnf:longest p)))
    112     ))
    113 
    114 (define lcollect-strings (lcollect string?))
    115 
    116 ;; shortcut for (abnf:bind (lcollect-strings ...) (abnf:longest ... ))
    117 (define-syntax consumed-strings->list
    118   (syntax-rules ()
    119     ((_ l p)    (abnf:bind (lcollect-strings l)  (abnf:longest p)))
    120     ((_ p)      (abnf:bind (lcollect-strings)    (abnf:longest p)))
    121     ))
    122 
    123 (define lcollect-pairs  (lcollect pair?))
    124 
    125 ;; shortcut for (abnf:bind (lcollect-pairs ...) (abnf:longest ... ))
    126 (define-syntax consumed-pairs->list
    127   (syntax-rules ()
    128     ((_ l p)    (abnf:bind (lcollect-pairs l)  (abnf:longest p)))
    129     ((_ p)      (abnf:bind (lcollect-pairs)    (abnf:longest p)))
    130     ))
    131 
     67(define consumed-objects-lift-any
     68  (abnf:consumed-objects-lift
     69   (abnf:consumed-objects identity)))
    13270
    13371;; Construct a parser for a message header line from the header's name
     
    13674(define (header s p) 
    13775  (let ((ss (->string s)))
    138     (abnf:bind ((lcollect identity))
     76    (abnf:bind (consumed-objects-lift-any)
    13977     (abnf:concatenation
    140       (consumed->tsymbol (abnf:lit ss))
     78      (bind-consumed->tsymbol (abnf:lit ss))
    14179      (abnf:drop-consumed (abnf:char #\:))
    14280      p
     
    239177;; trailing cfws
    240178
    241 (define atom (consumed->string (between-cfws (abnf:repetition1 atext))))
     179(define atom (abnf:bind-consumed->string (between-cfws (abnf:repetition1 atext))))
    242180
    243181;; Match two or more atext elements interspersed by dots.
     
    253191;; Match dot-atom-text and skip any preceeding or trailing cfws.
    254192
    255 (define dot-atom (consumed->string (between-cfws dot-atom-text)))
     193(define dot-atom (abnf:bind-consumed->string (between-cfws dot-atom-text)))
    256194
    257195;; Quoted strings (section 3.2.4)
     
    273211
    274212(define quoted-string
    275   (consumed->string
     213  (abnf:bind-consumed->string
    276214   (between-cfws
    277215    (abnf:concatenation
     
    292230;; Match either one or more word elements
    293231
    294 (define phrase (consumed-strings->list (abnf:repetition1 word)))
     232(define phrase
     233  (abnf:bind-consumed-strings->list (abnf:repetition1 word)))
    295234
    296235
     
    300239
    301240(define unstructured
    302   (consumed->string
     241  (abnf:bind-consumed->string
    303242   (abnf:concatenation
    304243    (abnf:repetition
     
    337276;; Match a day-name, optionally wrapped in folding whitespace
    338277
    339 (define day-of-week (consumed-strings->list 'day-of-week (between-fws-drop (consumed->string day-name))))
     278(define day-of-week
     279  (abnf:bind-consumed-strings->list
     280   'day-of-week
     281   (between-fws-drop
     282    (abnf:bind-consumed->string day-name))))
    340283
    341284
    342285;; Match a four digit decimal number
    343286
    344 (define year (between-fws-drop (consumed->string (abnf:repetition-n 4 abnf:decimal))))
     287(define year
     288  (between-fws-drop
     289   (abnf:bind-consumed->string (abnf:repetition-n 4 abnf:decimal))))
    345290
    346291;; Match the abbreviated month names
     
    363308;; Match a month-name, optionally wrapped in folding whitespace
    364309
    365 (define month (between-fws-drop (consumed->string month-name)))
     310(define month (between-fws-drop (abnf:bind-consumed->string month-name)))
    366311
    367312
     
    371316             (abnf:drop-consumed (abnf:optional-sequence fws))
    372317             (abnf:alternatives
    373               (consumed->string (abnf:variable-repetition 1 2 abnf:decimal))
     318              (abnf:bind-consumed->string (abnf:variable-repetition 1 2 abnf:decimal))
    374319              (abnf:drop-consumed fws))))
    375320
    376321;; Match a date of the form dd:mm:yyyy
    377 (define date (consumed-strings->list 'date (abnf:concatenation day month year)))
     322(define date
     323  (abnf:bind-consumed-strings->list 'date
     324    (abnf:concatenation day month year)))
    378325
    379326;; Match a two-digit number
    380327
    381 (define hour      (consumed->string (abnf:repetition-n 2 abnf:decimal)))
    382 (define minute    (consumed->string (abnf:repetition-n 2 abnf:decimal)))
    383 (define isecond   (consumed->string (abnf:repetition-n 2 abnf:decimal)))
     328(define hour      (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
     329(define minute    (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
     330(define isecond   (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
    384331
    385332;; Match a time-of-day specification of hh:mm or hh:mm:ss.
     
    396343(define zone (abnf:concatenation
    397344              (abnf:drop-consumed fws)
    398               (consumed->string (abnf:alternatives (abnf:char #\-) (abnf:char #\+)))
     345              (abnf:bind-consumed->string (abnf:alternatives (abnf:char #\-) (abnf:char #\+)))
    399346              hour minute))
    400347
    401348;; Match a time-of-day specification followed by a zone.
    402349
    403 (define itime (consumed-strings->list 'time (abnf:concatenation time-of-day zone)))
     350(define itime
     351  (abnf:bind-consumed-strings->list 'time
     352    (abnf:concatenation time-of-day zone)))
    404353
    405354(define date-time (abnf:concatenation
     
    433382                         (abnf:concatenation
    434383                          (abnf:drop-consumed (abnf:char #\[))
    435                           (consumed->string
     384                          (abnf:bind-consumed->string
    436385                           (abnf:repetition
    437386                            (abnf:concatenation
     
    455404(define addr-spec
    456405  (abnf:concatenation
    457    (consumed-strings->list 'local-part local-part)
     406   (abnf:bind-consumed-strings->list 'local-part local-part)
    458407   (abnf:drop-consumed (abnf:char #\@))
    459    (consumed-strings->list 'domain domain)))
     408   (abnf:bind-consumed-strings->list 'domain domain)))
    460409
    461410;; Parse an angle-addr
     
    471420
    472421;; Parse and return a phrase.
    473 (define display-name  (consumed-pairs->list 'display-name phrase))
     422(define display-name  (abnf:bind-consumed-pairs->list 'display-name phrase))
    474423
    475424;; Match an angle-addr, optionally prefaced with a display-name
     
    482431;; Match a name-addr or an addr-spec and return the address.
    483432
    484 (define mailbox (consumed-pairs->list 'mailbox (abnf:alternatives name-addr addr-spec)))
     433(define mailbox
     434  (abnf:bind-consumed-pairs->list 'mailbox
     435   (abnf:alternatives name-addr addr-spec)))
    485436
    486437;; Parse a list of mailbox addresses, every two addresses being
     
    488439
    489440(define mailbox-list
    490   (consumed-pairs->list 'mailbox-list
     441  (abnf:bind-consumed-pairs->list 'mailbox-list
    491442   (abnf:concatenation
    492443    mailbox
     
    504455;;    my group: user1@example.org, user2@example.org;
    505456
    506 (define group (vac (consumed-pairs->list 'group
     457(define group (vac (abnf:bind-consumed-pairs->list 'group
    507458                   (abnf:concatenation
    508459                    display-name
     
    540491               (abnf:repetition
    541492                (abnf:concatenation
    542                  (consumed->string (abnf:repetition text))
     493                 (abnf:bind-consumed->string (abnf:repetition text))
    543494                 (abnf:drop-consumed abnf:crlf)))
    544                (consumed->string (abnf:repetition text)))))
     495               (abnf:bind-consumed->string (abnf:repetition text)))))
    545496
    546497;; Field definitions (section 3.6)
     
    617568
    618569(define msg-id
    619   (consumed-strings->list 'message-id
     570  (abnf:bind-consumed-strings->list 'message-id
    620571    (between-cfws-drop
    621572     (abnf:concatenation
    622573      (abnf:drop-consumed (abnf:char #\<))
    623       (consumed->string id-left)
     574      (abnf:bind-consumed->string id-left)
    624575      (abnf:drop-consumed (abnf:char #\@))
    625       (consumed->string id-right)
     576      (abnf:bind-consumed->string id-right)
    626577      (abnf:drop-consumed (abnf:char #\>))
    627578      ))))
     
    727678(define return-path  (header "Return-Path" path))
    728679
    729 (define received-token (consumed-strings->list 'received-token (abnf:alternatives domain angle-addr addr-spec word)))
     680(define received-token
     681  (abnf:bind-consumed-strings->list
     682   'received-token
     683   (abnf:alternatives domain angle-addr addr-spec word)))
    730684
    731685(define received  (header "Received" 
     
    748702;; more ftext characters.
    749703
    750 (define field-name (consumed->tsymbol (abnf:repetition1 ftext)))
     704(define field-name (bind-consumed->tsymbol (abnf:repetition1 ftext)))
    751705
    752706;; Parse an arbitrary header field and return a tuple containing the
     
    755709
    756710(define optional-field 
    757   (abnf:bind ((lcollect identity))
     711  (abnf:bind (consumed-objects-lift-any)
    758712             (abnf:concatenation
    759713              field-name
     
    807761
    808762(define message
    809   (consumed-pairs->list
     763  (abnf:bind-consumed-pairs->list
    810764   'message
    811765   (abnf:concatenation
    812     (consumed-pairs->list 'fields fields)
     766    (abnf:bind-consumed-pairs->list 'fields fields)
    813767    (abnf:optional-sequence
    814768     (abnf:concatenation
    815769      (abnf:drop-consumed abnf:crlf)
    816       (consumed-strings->list 'body body))))))
     770      (abnf:bind-consumed-strings->list 'body body))))))
    817771
    818772
  • release/4/internet-message/trunk/internet-message.setup

    r15071 r15802  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O2 -d0 -s internet-message.scm -j internet-message)
     6(compile -O -d2 -s internet-message.scm -j internet-message)
    77(compile -s internet-message.import.scm)
    88
Note: See TracChangeset for help on using the changeset viewer.