◊(Local Yarn Code "Diff")

Login
About History Code Code Docs Road Map Issues
Annotate Patch Side-by-side Diff

Differences From Artifact [402b4b9e]:

To Artifact [43f7824f]:

︙
32
33
34
35
36
37
38

39

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60


61
62
63
64
65
66
67

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60


61
62
63
64
65
66
67
68
69








+

+



















-
-
+
+









;; Provides common helper functions used throughout the project

(provide maybe-meta     ; Select from (current-metas) or default value ("") if not available
         maybe-attr     ; Return an attribute’s value or a default ("") if not available
         series-noun    ; Retrieve noun-singular from current 'series meta, or ""
         series-title   ; Retrieve title of series in current 'series meta, or ""
         series-pagenode
         attr-present?  ; Test if an attribute is present
         make-tag-predicate
         tx-strs
         ymd->english
         ymd->dateformat
         default-authorname
         default-title
         articles-path
         series-path
         articles-pagetree
         series-pagetree
         first-words
         build-note-id
         notes->last-disposition-values
         disposition-values
         )

(define default-authorname "Joel Dueck")
(define series-path "series")
(define articles-path "articles")

(define (default-title date)
  (format "Entry of ~a" (ymd->dateformat date "d MMM YYYY")))
(define (default-title body-txprs)
  (format "“~a…”" (first-words body-txprs 5)))

(define (maybe-meta m [missing ""])
  (or (select-from-metas m (current-metas)) missing))

;; Checks current-metas for a 'series meta and returns the pagenode of that series,
;; or '|| if no series is specified.
(define (series-pagenode)
︙
108
109
110
111
112
113
114




115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142






































































143
144
145
146
147
148
149

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126







127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218








+
+
+
+






-
-
-
-
-
-
-















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+









(define (maybe-attr name attrs [missing ""])
  (define result (assoc name attrs))
  (cond
    [(pair? result) (cadr result)]
    [else missing]))

;; Returns a function will test if a txexpr's tag matches the given symbol.
(define (make-tag-predicate tagsym)
  (lambda (tx) (and (txexpr? tx) (equal? tagsym (get-tag tx)))))

(define (tx-strs xpr)
  (cond
    [(txexpr? xpr) (apply string-append (map tx-strs (get-elements xpr)))]
    [(string? xpr) xpr]
    [else ""]))

(define (first-words str n)
  (define trunc
    (apply string-append
         (add-between (take (string-split str) n) " ")))
  ;; Remove trailing punctuation (commas, etc.)
  (regexp-replace #px"\\W+$" trunc ""))

(module+ test
  (require rackunit)
  (define test-metas (hash 'name "Fiver" 'size "Small"))
  (define test-attrs '([name "Hazel"] [rank "Chief"]))

  (parameterize ([current-metas test-metas])
    (check-equal? (maybe-meta 'name) "Fiver") ; present meta
    (check-equal? (maybe-meta 'age) "")       ; missing meta
    (check-equal? (maybe-meta 'age 2) 2))      ; alternate default value
  
  (check-equal? (attr-present? 'name test-attrs) #t)
  (check-equal? (attr-present? 'dingus test-attrs) #f)
  (check-equal? (maybe-attr 'rank test-attrs) "Chief")
  (check-equal? (maybe-attr 'dingus test-attrs) "")
  (check-equal? (maybe-attr 'dingus test-attrs "zippy") "zippy"))

;; Return the first N words out of a list of txexprs. This function will unpack the strings out of
;; the elements of one txexpr at a time until it finds the requested number of words. It aims to be
;; both reliable and fast for any size of list you pass it, and smart about the punctuation it
;; allows through.
(define (first-words txprs words-needed)
  (define punc-allowed-in-word '(#\- #\' #\% #\$ #\‘ #\’ #\# #\& #\/ #\. #\!))
  
  (define (word-boundary? c) (or (char-whitespace? c) (equal? c #\null) (eof-object? c)))
  (define (word-char? c) (or (char-alphabetic? c) (char-numeric? c)))
  
  (define in (open-input-string (tx-strs (first txprs))))
  (define out (open-output-string))
  
  (define words-found
    (let loop ([words-found 0] [last-c #\null] [last-c-in-word? #f])
      (define c (read-char in))

      (cond [(equal? words-found words-needed) words-found]
            [(eof-object? c)
             (cond [(positive? words-found) (if last-c-in-word? (+ 1 words-found) words-found)]
                   [else 0])]
            [else
             (define-values (write-this-char? new-word-count c-in-word?)
               (cond
                 ;; Spaces increment the word count if the previous character was part of,
                 ;; or adjacent to, a word
                 [(and (char-whitespace? c) last-c-in-word?)
                  (values (if (equal? words-needed (+ 1 words-found)) #f #t) (+ 1 words-found) #f)]
                 ;; Some punctuation survives if the previous or next char is part of a word
                 [(member c punc-allowed-in-word)
                  (cond [(or (word-char? last-c) (word-char? (peek-char in)))
                         (values #t words-found #t)]
                        [else (values #f words-found #f)])]
                 [(word-char? c)
                  (values #t words-found #t)]
                 ;; If c is a non-whitespace non-allowed character that immediately follows a word,
                 ;; do not write it out but count it as being part of the word.   
                 [(and (not (word-char? c)) (not (char-whitespace? c)) last-c-in-word?)
                  (values #f words-found #t)]
                 [else (values #f words-found #f)]))

             (cond [write-this-char? (write-char c out)])
             (loop new-word-count c c-in-word?)])))
  
  (define words (get-output-string out))
  (cond [(equal? words-found words-needed) words]
        [(equal? '() (rest txprs)) words]
        [else (string-append words " " (first-words (rest txprs) (- words-needed words-found)))]))

(module+ test
  (require rackunit)
  (define txs-decimals
    '((p "Four score and 7.8 years ago — our fathers brought forth on this continent etc etc")))
  (define txs-punc+split-elems
    '((p "“Stop!” she called.") (p "(She was never one to be silent.)")))
  (define txs-dashes
    '((p [[class "newthought"]] (span [[class "smallcaps"]] "One - and") " only one.")
      (p "That was all she would allow.")))
  (define txs-parens-commas
    '((p "She counted (" (em "one, two") "— silently, eyes unblinking")))
  (define txs-short
    '((span "Not much here!")))

  (check-equal? (first-words txs-decimals 5) "Four score and 7.8 years")
  (check-equal? (first-words txs-punc+split-elems 5) "Stop! she called. She was")
  (check-equal? (first-words txs-dashes 5) "One and only one. That")
  (check-equal? (first-words txs-dashes 4) "One and only one.")
  (check-equal? (first-words txs-parens-commas 5) "She counted one two silently")
  (check-equal? (first-words txs-short 5) "Not much here!"))
                
;; Convert, e.g., "* thoroughly recanted" into (values "*" "thoroughly recanted")
(define (disposition-values str)
  (cond [(string=? "" str) (values "" "")]
        [else (let ([splut (string-split str)])
                (values (car splut) (string-join (cdr splut))))]))
︙
This page was generated in about 0.011s by Fossil 2.19 [318ab802db] 2022-05-27 02:05:21