Changeset 15547 in project


Ignore:
Timestamp:
08/23/09 13:39:47 (10 years ago)
Author:
sjamaan
Message:

Port fancypants to Chicken 4

Location:
release/4
Files:
2 deleted
5 edited
1 copied

Legend:

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

    r13974 r15547  
    55   "Automatic ASCII smart quotes and ligature handling for SXML")
    66 (author "Peter Bex")
     7 (test-depends sxml-transforms test)
    78 (category web)
    89 (license "BSD")
    9  (needs sxml-transforms)
    10  (files "fancypants.scm" "fancypants-eggdoc.scm" "fancypants.html" "fancypants.setup"))
     10 (doc-from-wiki)
     11 (files "fancypants.scm" "fancypants.setup" "tests"))
  • release/4/fancypants/fancypants.scm

    r14852 r15547  
    2828; SUCH DAMAGE.
    2929
    30 (declare
    31  (hide point-split-string parts->regex flatten-string))
    32 
    33 (use srfi-1 srfi-13 sxml-transforms regex)
     30(module fancypants
     31  (fancify smarten-quotes
     32   make-fancy-rules make-smart-quote-rules
     33   default-exceptions default-ligature-map default-punctuation-map
     34   default-arrow-map default-map all-quotes)
     35
     36(import chicken scheme)
     37
     38(use data-structures srfi-1 srfi-13 regex)
     39(import irregex)
    3440
    3541;; Split up a string at predefined points, returning a list with the pieces.
     
    4046     ((= (string-length string) 0) '())
    4147     ((string-contains string (car p)) => (lambda (start)
    42                                             (let ((len (string-length (car p))))
    43                                               (append (point-split-string (string-take string start) points)
    44                                                       (list (string-copy string start (+ start len)))
    45                                                       (point-split-string (string-drop string (+ start len)) points)))))
     48                                            (let ((len (string-length (car p))))
     49                                              (append (point-split-string (string-take string start) points)
     50                                                      (list (string-copy string start (+ start len)))
     51                                                      (point-split-string (string-drop string (+ start len)) points)))))
    4652     (else (loop (cdr p))))))
    4753
     
    5359    ("fi"  . (& "#xfb01"))
    5460    ("fl"  . (& "#xfb02"))
    55 ;   ("st"  . (& "#xfb06"))  ;; This one is too conspicuous in standard fonts
     61    ;;   ("st"  . (& "#xfb06"))  ;; This one is too conspicuous in standard fonts
    5662    ("ft"  . (& "#xfb05"))))
    5763
     
    6167    (".."    . (& "#x2025"))
    6268    (". . ." . (& "#x2026"))
    63     ; We could also use #x2013, #x2014 instead.
     69    ;; We could also use #x2013, #x2014 instead.
    6470    ("---"   . (& "mdash"))
    6571    ("--"    . (& "ndash"))))
     
    7985
    8086(define default-map `(,@default-ligature-map
    81                       ,@default-punctuation-map
    82                       ,@default-arrow-map))
     87                       ,@default-punctuation-map
     88                       ,@default-arrow-map))
    8389
    8490;; Don't try to do anything with these
     
    8995(define (fancify string character-map)
    9096  (map (lambda (piece)
    91          (alist-ref piece character-map string=? piece))  ; alist-ref is Chicken-specific
     97         (alist-ref piece character-map string=? piece))
    9298       (point-split-string string (map car character-map))))
    9399
    94100(define (make-fancy-rules . rest)
    95101  (let-optionals rest ((exceptions default-exceptions)
    96                        (character-map default-map))
     102                       (character-map default-map))
    97103    `(,@(map (lambda (x)
    98                `(,x *preorder* . ,(lambda x x))) exceptions)
     104               `(,x *preorder* . ,(lambda x x))) exceptions)
    99105      (*text* . ,(lambda (tag str)
    100                    (if (string? str)
    101                        (cons '*flatten* (fancify str character-map))
    102                        str)))
     106                   (if (string? str)
     107                       (cons '*flatten* (fancify str character-map))
     108                       str)))
    103109      (*default* . ,(lambda contents
    104                       (flatten-strings contents))))))
     110                      (flatten-strings contents))))))
    105111
    106112;; Structure of these lists: (pre match post how counts?)
    107113;; pre is the part of the string that's before the quote to match, post is the
    108 ;; string that is after the match (any may be #f).
     114;; string that is after the match (can be empty).
    109115;; how is one of single, double, single-open, double-open, single-close
    110116;; or double-close.
     
    112118;; nesting of the next quote or not.  (ie, "isn't" => #f, since the '
    113119;; doesn't mean an opening quote is closed by the quote).
    114 ;; Note that you (currently) can't use brackets in these regexes, since that
    115 ;; messes up the expected structure of the result of string-search-positions.
    116 (define all-quotes '(("n" "'"  "t"  single-close #f) ; Aren't you?
    117                      (#f  "'"  "re" single-close #f) ; We're here
    118                      (#f  "'"  "s"  single-close #f) ; Jack's widget
    119                      ("s" "'" " |$" single-close #f) ; The Jacksons' car
    120                      ("^| " "'" "[0-9]+s" single-close #f) ; The '90s
    121                      (#f  "\"" #f   double #t)
    122                      (#f  "``" #f   double-open #t)
    123                      (#f  "''" #f   double-close #t)
    124                      (#f  "'"  #f   single #t)))
    125 
    126 ;; Note we might need to escape parens.  In the end I probably want to
    127 ;; replace this hack with SREs (scsh-regexp), which are composable.
    128 (define (parts->regex pre match post)
    129   (string-append "(" (or pre "") ")"
    130                  "(" (or match "") ")"
    131                  "(" (or post "") ")"))
     120(define all-quotes
     121  '(("n"          "'"  "t"                   single-close #f) ; Aren't you?
     122    (""           "'"  "re"                  single-close #f) ; We're here
     123    (""           "'"  "s"                   single-close #f) ; Jack's widget
     124    ("s"          "'"  (or " " eos)          single-close #f) ; James' car
     125    ((or bos " ") "'"  (seq (+ numeric) "s") single-close #f) ; The '90s
     126    (""           "\"" ""                    double #t)
     127    (""           "``" ""                    double-open #t)
     128    (""           "''" ""                    double-close #t)
     129    (""           "'"  ""                    single #t)))
    132130
    133131;; See http://www.unicode.org/charts/PDF/U2000.pdf
     
    135133(define (smarten-quotes contents #!optional (quotes all-quotes) (exceptions default-exceptions))
    136134  (let ((single-open-count 0)
    137         (double-open-count 0)
    138         (big-regex  (string-join (map (lambda (parts)
    139                                         (parts->regex (first parts) (second parts) (third parts)))
    140                                       quotes) "|")))
     135        (double-open-count 0)
     136        (big-regex (irregex
     137                    `(or ,@(map (lambda (parts)
     138                                  `(seq (submatch ,(first parts))
     139                                        (submatch ,(second parts))
     140                                        (submatch ,(third parts))))
     141                                quotes)))))
    141142    (let loop ((contents contents)
    142                (result '()))
     143               (result '()))
    143144      (cond
    144145       ((null? contents) (reverse result))
     
    154155                      (loop (cdr contents) result)
    155156                      (loop (cdr contents) (cons (cons '*flatten* string-list) result))))
    156                 (let* ((before (string-take str (caar pos))) ;; non-matching part
    157                        (after  (string-drop str (cadar pos))) ;; non-matching part
    158                        (match-pos  (list-index identity (cdr pos)))
    159                        (parts (car (drop quotes (quotient match-pos 3)))) ;; Three parts of the matching quotes
    160                        (matching (drop (cdr pos) match-pos)) ;; Matching positions (corresponding to parts)
     157                (let* ((before (string-take str (caar pos))) ; non-matching part
     158                       (after  (string-drop str (cadar pos))) ; non-matching part
     159                       (match-pos  (list-index (lambda (x) (car x)) (cdr pos)))
     160                        ;; Three parts of the matching quotes
     161                       (parts (car (drop quotes (quotient match-pos 3))))
     162                       ;; Matching positions (corresponding to parts)
     163                       (matching (drop (cdr pos) match-pos))
    161164                       (pre  (string-copy str (car (first matching)) (cadr (first matching))))
    162165                       (post (string-copy str (car (third matching)) (cadr (third matching))))
     
    165168                          ((single-open)
    166169                           (when (fifth parts)
    167                                (set! single-open-count (add1 single-open-count)))
     170                             (set! single-open-count (add1 single-open-count)))
    168171                           '(& "#x2018"))
    169172                          ((single-close)
    170173                           (when (and (fifth parts) (> single-open-count 0))
    171                                (set! single-open-count (sub1 single-open-count)))
     174                             (set! single-open-count (sub1 single-open-count)))
    172175                           '(& "#x2019"))
    173176                          ((double-open)
    174177                           (when (fifth parts)
    175                                (set! double-open-count (add1 double-open-count)))
     178                             (set! double-open-count (add1 double-open-count)))
    176179                           '(& "#x201c"))
    177180                          ((double-close)
    178181                           (when (and (fifth parts) (> double-open-count 0))
    179                                (set! double-open-count (sub1 double-open-count)))
     182                             (set! double-open-count (sub1 double-open-count)))
    180183                           '(& "#x201d"))
    181184                          ;; For the balanced ones, close it if it was open,
     
    200203                  (string-loop
    201204                   after
    202                    ;; XXX don't use empty strings for before/pre and post
    203205                   (append result-strings
    204206                           (list (string-append before pre) new-quote post))))))))
     
    212214(define (flatten-strings data)
    213215  (let loop ((data data)
    214              (result '()))
     216             (result '()))
    215217    (cond
    216218     ((null? data) (reverse result))
     
    226228(define (make-smart-quote-rules . rest)
    227229  (let-optionals rest ((exceptions default-exceptions)
    228                        (quotes all-quotes))
    229      `((*text* . ,(lambda (tag data) data))  ;; Not needed?
    230        (*default* *preorder* . ,(lambda (tag . contents)
    231                                   (flatten-strings (cons tag (smarten-quotes contents quotes exceptions))))))))
     230                       (quotes all-quotes))
     231    `((*text* . ,(lambda (tag data) data)) ;; Not needed?
     232      (*default* *preorder* . ,(lambda (tag . contents)
     233                                 (flatten-strings (cons tag (smarten-quotes contents quotes exceptions))))))))
     234)
  • release/4/fancypants/fancypants.setup

    r13974 r15547  
    11;; -*- scheme -*-
    2 (run (csc -s -O2 -d0 fancypants.scm))
     2(run (csc -s -O2 -d0 fancypants.scm -j fancypants))
     3(run (csc -s -O2 -d0 fancypants.import.scm))
    34
    4 (install-extension 'fancypants
    5                    '("fancypants.so")
    6                    '((version "0.2")
    7                      (documentation "fancypants.html")))
     5(install-extension
     6 'fancypants
     7 '("fancypants.so" "fancypants.import.so")
     8 '((version "0.3")
     9   (documentation "fancypants.html")))
  • release/4/fancypants/tests/run.scm

    r14852 r15547  
    1 (require-extension syntax-case test sxml-transforms)
     1(require-extension test sxml-transforms)
    22
    33(load "../fancypants.scm")
     4(import fancypants)
    45
    56(test-group "fancification"
  • release/4/http-client/trunk/http-client.scm

    r15204 r15547  
    333333                  (header-param 'www-authenticate 'realm
    334334                                (response-headers response)))
     335                 ;; TODO: Maybe we should implement a way to make it ask
     336                 ;; the question only once. This would be faster, but
     337                 ;; maybe less secure.
    335338                 (case authtype
    336339                   ((basic)
     
    345348                                     (request-headers req)))))
    346349                   ((digest)
    347                     (loop (add1 attempts) redirects req)) ;; TODO
     350                    (let* ((params (header-params 'www-authenticate
     351                                                  (response-headers response)))
     352                           (qops (alist-ref 'qop header-params eq? '()))
     353                           (qop (cond
     354                                 ((member 'auth-int qops) 'auth-int)
     355                                 ((member 'auth qops) 'auth)
     356                                 (else #f)))
     357                           (cnonce (and qop "client-nonce-TODO"))
     358                           (nonce (header-param 'nonce header-params))
     359                           (nc (and qop 1)) ;; TODO
     360                           (hashconc (lambda args
     361                                       (md5 (string-join
     362                                             (map ->string args) ":"))))
     363                           (realm (alist-ref 'realm header-params))
     364                           (method (alist-ref 'method header-params))
     365                           (h1 (hashconc username realm password))
     366                           (h2 (if (eq? qop 'auth-int)
     367                                   (hashconc method
     368                                             (uri->string
     369                                              (request-uri req)
     370                                              (constantly ""))
     371                                             "message-body") ; TODO
     372                                   (hashconc method (uri->string
     373                                                     (request-uri req)
     374                                                     (constantly "")))))
     375                           (response-digest
     376                            (case qop
     377                              ((auth-int) #f ; TODO
     378                               )
     379                              ((auth) #f ; TODO
     380                               )
     381                              (else
     382                               (conc h1 nonce h2)))))
     383                      (loop (add1 attempts)
     384                            redirects
     385                            (update-request
     386                             req
     387                             headers:
     388                             (headers
     389                              `((authorization
     390                                 #(digest
     391                                   ((username . ,username)
     392                                    (uri . ,(request-uri req))
     393                                    (realm . ,(alist-ref params 'realm))
     394                                    (nonce . ,(alist-ref params 'nonce))
     395                                    (cnonce . ,cnonce)
     396                                    (nc . ,nc)
     397                                    (response . ,response-digest)
     398                                    (opaque . ,(alist-ref params 'opaque))))))
     399                              (request-headers req))))))
    348400                   (else (error "Should never get here"))))
    349401               ;; pass it on, we can't throw an error here
Note: See TracChangeset for help on using the changeset viewer.