source: project/release/4/fancypants/fancypants.scm @ 15547

Last change on this file since 15547 was 15547, checked in by sjamaan, 10 years ago

Port fancypants to Chicken 4

File size: 11.2 KB
Line 
1;;; fancypants - Automatic ASCII smart quotes and ligature handling for SXML
2;
3; Copyright (c) 2006-2009 Peter Bex (Peter.Bex@xs4all.nl)
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without
7; modification, are permitted provided that the following conditions
8; are met:
9; 1. Redistributions of source code must retain the above copyright
10;    notice, this list of conditions and the following disclaimer.
11; 2. Redistributions in binary form must reproduce the above copyright
12;    notice, this list of conditions and the following disclaimer in the
13;    documentation and/or other materials provided with the distribution.
14; 3. Neither the name of Peter Bex nor the names of any contributors may
15;    be used to endorse or promote products derived from this software
16;    without specific prior written permission.
17;
18; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
19; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
21; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
22; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
25; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
27; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
28; SUCH DAMAGE.
29
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)
40
41;; Split up a string at predefined points, returning a list with the pieces.
42(define (point-split-string string points)
43  (let loop ((p points))
44    (cond
45     ((null? p) (list string))
46     ((= (string-length string) 0) '())
47     ((string-contains string (car p)) => (lambda (start)
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)))))
52     (else (loop (cdr p))))))
53
54;; See http://www.unicode.org/charts/PDF/UFB00.pdf
55(define default-ligature-map
56  '(("ffi" . (& "#xfb03"))
57    ("ffl" . (& "#xfb04"))
58    ("ff"  . (& "#xfb00"))
59    ("fi"  . (& "#xfb01"))
60    ("fl"  . (& "#xfb02"))
61    ;;   ("st"  . (& "#xfb06"))  ;; This one is too conspicuous in standard fonts
62    ("ft"  . (& "#xfb05"))))
63
64;; See http://www.unicode.org/charts/PDF/U2000.pdf
65(define default-punctuation-map
66  '(("..."   . (& "#x2026"))
67    (".."    . (& "#x2025"))
68    (". . ." . (& "#x2026"))
69    ;; We could also use #x2013, #x2014 instead.
70    ("---"   . (& "mdash"))
71    ("--"    . (& "ndash"))))
72
73;; See http://www.unicode.org/charts/PDF/U2190.pdf
74(define default-arrow-map
75  '(("->>" . (& "#x21a0"))
76    ("<<-" . (& "#x219e"))
77    ("->|" . (& "#x21e5"))
78    ("|<-" . (& "#x21e4"))
79    ("<->" . (& "#x2194"))
80    ("->"  . (& "#x2192"))
81    ("<-"  . (& "#x2190"))
82    ("<=>" . (& "#x21d4"))
83    ("=>"  . (& "#x21d2"))
84    ("<="  . (& "#x21d0"))))
85
86(define default-map `(,@default-ligature-map
87                       ,@default-punctuation-map
88                       ,@default-arrow-map))
89
90;; Don't try to do anything with these
91(define default-exceptions '(head script pre code kbd samp @))
92
93;; Split ASCII "ligatures" and such from their surrounding strings and change
94;; them to their respective Unicode ligature. ie, "fine" => ((& "#xfb01") "ne")
95(define (fancify string character-map)
96  (map (lambda (piece)
97         (alist-ref piece character-map string=? piece))
98       (point-split-string string (map car character-map))))
99
100(define (make-fancy-rules . rest)
101  (let-optionals rest ((exceptions default-exceptions)
102                       (character-map default-map))
103    `(,@(map (lambda (x)
104               `(,x *preorder* . ,(lambda x x))) exceptions)
105      (*text* . ,(lambda (tag str)
106                   (if (string? str)
107                       (cons '*flatten* (fancify str character-map))
108                       str)))
109      (*default* . ,(lambda contents
110                      (flatten-strings contents))))))
111
112;; Structure of these lists: (pre match post how counts?)
113;; pre is the part of the string that's before the quote to match, post is the
114;; string that is after the match (can be empty).
115;; how is one of single, double, single-open, double-open, single-close
116;; or double-close.
117;; counts? is a boolean describing whether the quote should influence the
118;; nesting of the next quote or not.  (ie, "isn't" => #f, since the '
119;; doesn't mean an opening quote is closed by the quote).
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)))
130
131;; See http://www.unicode.org/charts/PDF/U2000.pdf
132;; This is pretty ugly code.
133(define (smarten-quotes contents #!optional (quotes all-quotes) (exceptions default-exceptions))
134  (let ((single-open-count 0)
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)))))
142    (let loop ((contents contents)
143               (result '()))
144      (cond
145       ((null? contents) (reverse result))
146       ((member (car contents) exceptions) (append (reverse result) contents))
147       ((pair? (car contents)) (loop (cdr contents) (cons (loop (car contents) '()) result)))
148       ((string? (car contents))
149        (let string-loop ((str (car contents))
150                          (result-strings '()))
151          (let ((pos (string-search-positions big-regex str)))
152            (if (not pos)
153                (let ((string-list (append result-strings (list str))))
154                  (if (null? string-list)
155                      (loop (cdr contents) result)
156                      (loop (cdr contents) (cons (cons '*flatten* string-list) result))))
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))
164                       (pre  (string-copy str (car (first matching)) (cadr (first matching))))
165                       (post (string-copy str (car (third matching)) (cadr (third matching))))
166                       (new-quote 
167                        (case (fourth parts)
168                          ((single-open)
169                           (when (fifth parts)
170                             (set! single-open-count (add1 single-open-count)))
171                           '(& "#x2018"))
172                          ((single-close)
173                           (when (and (fifth parts) (> single-open-count 0))
174                             (set! single-open-count (sub1 single-open-count)))
175                           '(& "#x2019"))
176                          ((double-open)
177                           (when (fifth parts)
178                             (set! double-open-count (add1 double-open-count)))
179                           '(& "#x201c"))
180                          ((double-close)
181                           (when (and (fifth parts) (> double-open-count 0))
182                             (set! double-open-count (sub1 double-open-count)))
183                           '(& "#x201d"))
184                          ;; For the balanced ones, close it if it was open,
185                          ;; open it if it was closed
186                          ((single)
187                           (if (> single-open-count 0)
188                               (begin
189                                 (when (fifth parts) (set! single-open-count (sub1 single-open-count)))
190                                 '(& "#x2019"))
191                               (begin
192                                 (when (fifth parts) (set! single-open-count (add1 single-open-count)))
193                                 '(& "#x2018"))))
194                          ((double)
195                           (if (> double-open-count 0)
196                               (begin
197                                 (when (fifth parts) (set! double-open-count (sub1 double-open-count)))
198                                 '(& "#x201d"))
199                               (begin
200                                 (when (fifth parts) (set! double-open-count (add1 double-open-count)))
201                                 '(& "#x201c"))))
202                          (else (error 'smarten-quotes "Unkown quote matching type: " (fourth parts))))))
203                  (string-loop
204                   after
205                   (append result-strings
206                           (list (string-append before pre) new-quote post))))))))
207       (else (loop (cdr contents) (cons (car contents) result)))))))
208
209;; We have to jump through some hoops to get the SXML normalized again.
210;; That's what you get when trying to map one string to a list of strings :)
211;;
212;; NOTE: There's probably a way to eliminate all this reversing.
213;; This is inefficient.
214(define (flatten-strings data)
215  (let loop ((data data)
216             (result '()))
217    (cond
218     ((null? data) (reverse result))
219     ((not (pair? data)) (cons data result))
220     ((and (pair? (car data)) (eq? (caar data) '*flatten*))
221      (loop (cdr data) (append (reverse (loop (cdar data) '())) result)))
222     ((pair? (car data)) (loop (cdr data) (cons (loop (car data) '()) result)))
223     (else (loop (cdr data) (cons (car data) result))))))
224
225;; This is a very simple implementation, it doesn't really use pre-post-order.
226;; It's handy nonetheless because you can easily integrate it into an existing
227;; pre-post-order chain with sxml-apply-rules.
228(define (make-smart-quote-rules . rest)
229  (let-optionals rest ((exceptions default-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)
Note: See TracBrowser for help on using the repository browser.