◊(Local Yarn Code "Check-in [e81b4199]")

Overview
Comment:Use a tag instead of metas for title. Use default-title consistently. Refine first-words to be smarter about punctutation. Closes [c055cacb] and fixes [b3ade0b7]
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: e81b4199ad4f49b4797da6e379cca230b43b4f4a4d38d131017f2e9fdcf9fb9c
User & Date: joel on 2019-03-19 03:31:53
Other Links: manifest | tags
References
2019-03-19
03:37 Closed ticket [c055cacb]: Use a tag rather than a meta for article title plus 4 other changes artifact: da5cd2ea user: joel
Context
2019-03-20
00:41
Clean up small errors in code docs. Fixes [3510585b] check-in: 1787e5b0 user: joel tags: trunk
2019-03-19
03:31
Use a tag instead of metas for title. Use default-title consistently. Refine first-words to be smarter about punctutation. Closes [c055cacb] and fixes [b3ade0b7] check-in: e81b4199 user: joel tags: trunk
2019-03-16
21:22
Fixes for new use of poly-branch macros check-in: 7bb712ef user: joel tags: trunk
Changes

Modified code-docs/dust.scrbl from [d66853e3] to [71bc13f3].

9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

@(require "scribble-helpers.rkt"
          scribble/example)

@(require (for-label "../pollen.rkt"
                     "../dust.rkt"
                     racket/base

                     txexpr
                     sugar/coerce
                     pollen/tag
                     pollen/setup
                     pollen/pagetree
                     pollen/core))

@(define dust-eval (make-base-eval))
@(dust-eval '(require "dust.rkt"))

@title{@filepath{dust.rkt}}

@defmodule["dust.rkt" #:packages ()]

This is where I put constants and helper functions that are needed pretty much everywhere in the
project. In a simpler project these would go in @seclink["pollen-rkt"]{@filepath{pollen.rkt}} but







>








|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

@(require "scribble-helpers.rkt"
          scribble/example)

@(require (for-label "../pollen.rkt"
                     "../dust.rkt"
                     racket/base
                     racket/contract
                     txexpr
                     sugar/coerce
                     pollen/tag
                     pollen/setup
                     pollen/pagetree
                     pollen/core))

@(define dust-eval (make-base-eval))
@(dust-eval '(require "dust.rkt" txexpr))

@title{@filepath{dust.rkt}}

@defmodule["dust.rkt" #:packages ()]

This is where I put constants and helper functions that are needed pretty much everywhere in the
project. In a simpler project these would go in @seclink["pollen-rkt"]{@filepath{pollen.rkt}} but
71
72
73
74
75
76
77
78

79
80
81
82
83












84
85
86


87


88
89














90

91
92

93
94
95



96
97
98
99
100





101
102
103
104
105
106
107
108
@defproc[(maybe-meta [key symbolish?] [missing-expr any/c ""]) any/c]

Look up a value in @code{(current-metas)} that may or may not be present, returning the value of
@racket[_missing-expr] if it’s not there.

@defproc[(tx-strs [tx txexpr?]) string?]

Finds all the strings from the @emph{elements} of @racket[_tx] (ignoring attributes) and concatenates them together.


@examples[#:eval dust-eval
(tx-strs '(p [[class "intro"]] 
             (em "I’m not opening the safe") ", Wilson remembers thinking."))]













@defproc[(first-words [str string?] [n exact-nonnegative-integer?]) string?]

Returns a string containing the first @racket[_n] words of @racket[_str], removing any trailing


punctuation. It will trip on opening punctuation or punctuation surrounded by spaces.



@examples[#:eval dust-eval














(first-words "Another time, perhaps." 2)

(first-words "‘One problem’ – it don’t always do punctuation right." 3)]


@section{Article parsers and helpers}

@defproc[(default-title [date string?]) string?]




Titles are not required for articles, but there are contexts where you need something that
serves as a title if one is not present, and that’s what this function supplies.

@examples[#:eval dust-eval





(default-title "2018-02-19")]

@defproc[(series-pagenode) pagenode?]

If @code{(current-metas)} has the key @racket['series], converts its value to the pagenode pointing to
that series, otherwise returns @racket['||].

@defproc[(series-noun) string?]







|
>





>
>
>
>
>
>
>
>
>
>
>
>
|

|
>
>
|
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
>


|
>
>
>





>
>
>
>
>
|







72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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
150
@defproc[(maybe-meta [key symbolish?] [missing-expr any/c ""]) any/c]

Look up a value in @code{(current-metas)} that may or may not be present, returning the value of
@racket[_missing-expr] if it’s not there.

@defproc[(tx-strs [tx txexpr?]) string?]

Finds all the strings from the @emph{elements} of @racket[_tx] (ignoring attributes) and
concatenates them together.

@examples[#:eval dust-eval
(tx-strs '(p [[class "intro"]] 
             (em "I’m not opening the safe") ", Wilson remembers thinking."))]

@defproc[(make-tag-predicate [sym symbol?]) (-> any/c boolean?)]

Returns a function (or @italic{predicate}) that returns @racket[#t] if its argument is
a @racket[_txexpr] whose tag is @racket[_sym]. This predicate is useful for passing as the
@racket[_pred] expression in functions @racket[splitf-txexpr] and @racket[findf-txexpr].

@examples[#:eval dust-eval
(define is-aside? (make-tag-predicate 'aside))

(is-aside? '(q "I am not mad, Sir Topas. I say to you this house is dark."))
(is-aside? '(aside "How smart a lash that speech doth give my Conscience?"))]

@defproc[(first-words [txprs (listof txexpr?)] [n exact-nonnegative-integer?]) string?]

Given a list of tagged X-expressions, returns a string containing the first @racket[_n] words found
in the string elements of @racket[_txprs], or all of the words if there are less than @racket[_n]
words available. Used by @racket[default_title].

This function aims to be smart about punctuation, and equally fast no matter how large the list of
elements that you send it.

@examples[#:eval dust-eval
(define txs-decimals
  '((p "Four score and 7.8 years ago — our fathers etc etc")))
(define txs-punc-and-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!")))

(first-words txs-decimals 5)
(first-words txs-punc-and-split-elems 5)
(first-words txs-dashes 5)
(first-words txs-parens-commas 5)
(first-words txs-short 5)
]

@section{Article parsers and helpers}

@defproc[(default-title [body-txprs (listof txexpr?)]) string?]

Given a list of tagged X-expressions (the elements of an article’s doc, e.g.), returns a string
containing a suitable title for the document. (Uses @racket[first-words].)

Titles are not required for articles, but there are contexts where you need something that
serves as a title if one is not present, and that’s what this function supplies.

@examples[#:eval dust-eval
(define doc 
  '(root (p "If I had been astonished at first catching a glimpse of so outlandish an "
            "individual as Queequeg circulating among the polite society of a civilized "
            "town, that astonishment soon departed upon taking my first daylight "
            "stroll through the streets of New Bedford…")))
(default-title (get-elements doc))]

@defproc[(series-pagenode) pagenode?]

If @code{(current-metas)} has the key @racket['series], converts its value to the pagenode pointing to
that series, otherwise returns @racket['||].

@defproc[(series-noun) string?]

Modified code-docs/pollen.scrbl from [0a71a786] to [a5d17272].

54
55
56
57
58
59
60




61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78












79
80
81
82
83
84
85

The convention in this project is to define and provide these branch functions in separate files:
see, e.g., @filepath{tags-html.rkt}.

Functions defined with this macro @emph{do not} accept keyword arguments. If you need keyword
arguments, see @racket[poly-branch-kwargs-tag].





@defproc[#:kind "syntax"
         (poly-branch-kwargs-tag (id symbol?))
         (-> txexpr?)]

Works just like @racket[poly-branch-tag], but uses Pollen’s @racket[define-tag-function] so that
keyword arguments will automatically be parsed as X-expression attributes.

Additionally, the branch functions called from the new function must accept exactly two arguments:
a list of attributes and a list of elements.

@margin-note{The thought behind having two macros so similar is that, by cutting out handling for keyword
arguments, @racket[poly-branch-tag] could produce simpler and faster code. I have not verified if
this intuition is meaningful or correct.}

@section{Markup reference}

These are the tags that can be used in any of @italic{The Local Yarn}’s Pollen documents (articles,
etc).













@defproc[(p [element xexpr?] ...) txexpr?]

Wrap text in a paragraph. You almost never need to use this tag explicitly; 
just separate paragraphs by an empty line.

Single newlines within a paragraph will be replaced by spaces, allowing you to use







>
>
>
>










<
<
<
<




>
>
>
>
>
>
>
>
>
>
>
>







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74




75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

The convention in this project is to define and provide these branch functions in separate files:
see, e.g., @filepath{tags-html.rkt}.

Functions defined with this macro @emph{do not} accept keyword arguments. If you need keyword
arguments, see @racket[poly-branch-kwargs-tag].

@margin-note{The thought behind having two macros so similar is that, by cutting out handling for keyword
arguments, @racket[poly-branch-tag] could produce simpler and faster code. I have not verified if
this intuition is meaningful or correct.}

@defproc[#:kind "syntax"
         (poly-branch-kwargs-tag (id symbol?))
         (-> txexpr?)]

Works just like @racket[poly-branch-tag], but uses Pollen’s @racket[define-tag-function] so that
keyword arguments will automatically be parsed as X-expression attributes.

Additionally, the branch functions called from the new function must accept exactly two arguments:
a list of attributes and a list of elements.





@section{Markup reference}

These are the tags that can be used in any of @italic{The Local Yarn}’s Pollen documents (articles,
etc).

@defproc[(title [element xexpr?] ...) txexpr?]

@margin-note{The @code{title} function is not actually defined in @filepath{pollen.rkt} or anywhere
else. In Pollen, any undefined function @tt{title} defaults to @racket[(default-tag-function
title)], which is what I want. It is documented here because its presence or absence has
side-effects on the display of the article.}

Supplies a title for the document. You can use any otherwise-valid markup within the title tag. 

Titles are optional; if you don’t specify a title, the article will appear without one. This is
a feature!

@defproc[(p [element xexpr?] ...) txexpr?]

Wrap text in a paragraph. You almost never need to use this tag explicitly; 
just separate paragraphs by an empty line.

Single newlines within a paragraph will be replaced by spaces, allowing you to use

Modified crystalize.rkt from [2d723137] to [e57a2fd4].

95
96
97
98
99
100
101
102
103
104
105
106
107
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
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
    noun_plural
    noun_singular))

(define table_articles (make-table-schema "articles" table_articles-fields))
(define table_notes (make-table-schema "notes" table_notes-fields #:primary-key-cols '(pagenode note_id)))
(define table_series (make-table-schema "series" table_series-fields))

;; Split all ◊note tags out of the Pollen doc
(define (doc->body/notes doc)
  (define (is-note? tx) (and (txexpr? tx) (equal? 'note (get-tag tx))))
  (splitf-txexpr doc is-note?))

;; ~~~ Provided functions: Initializing; Saving posts and notes

;; Initialize the database connection, creating the database if it doesn’t
;; exist, and executing the table schema queries
;;
(define (spell-of-summoning!)
  (init-db! DBFILE table_articles table_notes table_series))

;; Save an article and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (crystalize-article! pagenode doc)
  (define pubdate (select-from-metas 'published (current-metas)))
  (define-values (body-txpr note-txprs) (doc->body/notes doc))

  (define doc-html (->html (cdr body-txpr)))
  
  (define-values (disposition disp-note-id)
    (notes->last-disposition-values note-txprs))



  (define title-specified? (non-empty-string? (maybe-meta 'title)))


  (define-values (title-plain title-html-flow)
    (title-plain+html-values body-txpr disposition))
  (define series-node (maybe-meta 'series))
  (define header (html$-article-open title-specified? title-html-flow pubdate))

  (define footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs)))
  (define footer (html$-article-close footertext))
  
  (define notes-section-html (crystalize-notes! pagenode title-plain note-txprs))

  ;; Values must come in the order defined in table_article_fields
  (define article-record
    (list (symbol->string pagenode)
          title-plain
          title-html-flow
          (bool->int title-specified?)
          pubdate
          (maybe-meta 'updated)
          (maybe-meta 'author default-authorname)
          (maybe-meta 'conceal)
          series-node
          (maybe-meta 'noun (series-noun))
          (length note-txprs)
          doc-html
          disposition
          disp-note-id
          (string-append header doc-html footer)
          "" ; listing_excerpt_html: Not yet used
          "")) ; listing_short_html: Not yet used

  (apply query! (make-insert/replace-query 'articles table_articles-fields) article-record)
          
  (string-append header doc-html notes-section-html footer))

;; ~~~ Article-related helper functions ~~~
;;

;; Return both a plain-text and HTML version of a title for the current article,
;; supplying a default if no title was specified in the metas.
(define (title-plain+html-values body-tx disposition)
  (define title (maybe-meta 'title ""))
  (define title-val
    (cond [(and (string? title) (string=? title ""))
           (format "“~a…”" (first-words (tx-strs body-tx) 5))]
          [else title]))
  
  (define disposition-part
    (cond [(non-empty-string? disposition)
           (define-values (mark _) (disposition-values disposition))
           (format "<span class=\"disposition-mark\">~a</span>" mark)]
          [else ""]))
  
  (cond [(txexpr? title-val)
         (values (apply string-append (tx-strs title-val))
                 (string-append (->html title-val) disposition-part))]
        [else (values title-val (string-append title-val disposition-part))]))

;; Convert a bunch of information about an article into some nice English and links.
(define (make-article-footertext pagenode series disposition disp-note-id note-count)
  (define s-title (series-title))
  (define s-noun (series-noun))
  (define series-part
    (cond [(non-empty-string? s-title)
           (format "This is ~a, part of <a href=\"/~a\">‘~a’</a>."







<
<
<
<
<












<
|
>
|
|


>
>
>
|
>
>
|
|
|
|
<
|
|
<
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|

|




<
|
|
<
|
|
<
|




|

|
<
<
|
<
|







95
96
97
98
99
100
101





102
103
104
105
106
107
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
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
    noun_plural
    noun_singular))

(define table_articles (make-table-schema "articles" table_articles-fields))
(define table_notes (make-table-schema "notes" table_notes-fields #:primary-key-cols '(pagenode note_id)))
(define table_series (make-table-schema "series" table_series-fields))






;; ~~~ Provided functions: Initializing; Saving posts and notes

;; Initialize the database connection, creating the database if it doesn’t
;; exist, and executing the table schema queries
;;
(define (spell-of-summoning!)
  (init-db! DBFILE table_articles table_notes table_series))

;; Save an article and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (crystalize-article! pagenode doc)

  (define-values
    (doc2 maybe-title) (splitf-txexpr doc (make-tag-predicate 'title)))
  (define-values 
    (body-txpr note-txprs) (splitf-txexpr doc2 (make-tag-predicate 'note)))
  (define-values (disposition disp-note-id)
    (notes->last-disposition-values note-txprs))
  
  (let* ([pubdate (select-from-metas 'published (current-metas))]
         [doc-html    (->html (cdr body-txpr))]
         [title-specified? (not (equal? '() maybe-title))]
         [title-val   (if (not (null? maybe-title)) (car maybe-title) maybe-title)]
         [title-tx    (make-article-title title-val body-txpr disposition disp-note-id)]
         [title-html  (->html title-tx)]
         [title-plain (tx-strs title-tx)]
         [series-node (series-pagenode)]
         [header      (html$-article-open title-specified? title-tx pubdate)]

         [footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs))]
         [footer (html$-article-close footertext)]

         [notes-section-html (crystalize-notes! pagenode title-plain note-txprs)])

    ;; Values must come in the order defined in table_article_fields
    (define article-record
      (list (symbol->string pagenode)
            title-plain
            title-html
            (bool->int title-specified?)
            pubdate
            (maybe-meta 'updated)
            (maybe-meta 'author default-authorname)
            (maybe-meta 'conceal)
            (symbol->string series-node)
            (maybe-meta 'noun (series-noun))
            (length note-txprs)
            doc-html
            disposition
            disp-note-id
            (string-append header doc-html footer)
            "" ; listing_excerpt_html: Not yet used
            "")) ; listing_short_html: Not yet used

    (apply query! (make-insert/replace-query 'articles table_articles-fields) article-record)
          
    (string-append header doc-html notes-section-html footer)))

;; ~~~ Article-related helper functions ~~~
;;


;; Return a title txexpr for the current article, constructing a default if no title text was specified.
(define (make-article-title supplied-title body-tx disposition disp-note-id)

  (define title-elems
    (cond [(null? supplied-title) (list (default-title (get-elements body-tx)))]

          [else (get-elements supplied-title)]))
  
  (define disposition-part
    (cond [(non-empty-string? disposition)
           (define-values (mark _) (disposition-values disposition))
           `(span [[class "disposition-mark"]] (a [[href ,(string-append "#" disp-note-id)]] ,mark))]
          [else ""]))
  ;; Returns a txexpr, the tag will be discarded by the template/snippets


  `(title ,@title-elems ,disposition-part))

  
;; Convert a bunch of information about an article into some nice English and links.
(define (make-article-footertext pagenode series disposition disp-note-id note-count)
  (define s-title (series-title))
  (define s-noun (series-noun))
  (define series-part
    (cond [(non-empty-string? s-title)
           (format "This is ~a, part of <a href=\"/~a\">‘~a’</a>."

Modified dust.rkt from [402b4b9e] to [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

;; 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 ""

         attr-present?  ; Test if an attribute is present

         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 (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)







>

>



















|
|







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 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

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





(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"))






































































                
;; 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))))]))








>
>
>
>






<
<
<
<
<
<
<















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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 ""]))








(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))))]))

Modified pollen.rkt from [d257d515] to [4cf3382b].

35
36
37
38
39
40
41
42
43
44

45
46
47
48
49
50
51
         "snippets-html.rkt"
         "crystalize.rkt")

(provide (all-defined-out)
         (all-from-out "crystalize.rkt" "snippets-html.rkt"))

(module setup racket/base
  (require syntax/modresolve)
  (provide (all-defined-out))
  (define poly-targets '(html))

  (define cache-watchlist
    (map resolve-module-path '("tags-html.rkt"
                               "snippets-html.rkt"
                               "dust.rkt"
                               "crystalize.rkt"))))

;; Macro for defining tag functions that automatically branch based on the 







|


>







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
         "snippets-html.rkt"
         "crystalize.rkt")

(provide (all-defined-out)
         (all-from-out "crystalize.rkt" "snippets-html.rkt"))

(module setup racket/base
  (require syntax/modresolve pollen/setup)
  (provide (all-defined-out))
  (define poly-targets '(html))
  (define block-tags (cons 'title default-block-tags))
  (define cache-watchlist
    (map resolve-module-path '("tags-html.rkt"
                               "snippets-html.rkt"
                               "dust.rkt"
                               "crystalize.rkt"))))

;; Macro for defining tag functions that automatically branch based on the 

Modified snippets-html.rkt from [704d9dde] to [fd84a05e].

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
(define (html$-page-body-open)
  ◊string-append{<body><main>
 <a href="/"><header>
 <img src="/web-extra/logo.png" height="103" width="129" class="logo">
 <h1>The Local Yarn</h1>
 </header></a>})

(define (html$-article-open title? title-html-flow published)
  (cond
    [title?
     ◊string-append{<article class="with-title hentry">
      <h1 class="entry-title">◊|title-html-flow|</h1>
      <p class="time"><a href="#" class="rel-bookmark">
      <time datetime="◊published" class="published">◊ymd->english[published]</time>
      </a></p>
      <section class="entry-content">}]
    [else
     ◊string-append{<article class="no-title hentry">
      <h1><a href="#" class="rel-bookmark">







|



|







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
(define (html$-page-body-open)
  ◊string-append{<body><main>
 <a href="/"><header>
 <img src="/web-extra/logo.png" height="103" width="129" class="logo">
 <h1>The Local Yarn</h1>
 </header></a>})

(define (html$-article-open title? title-tx published)
  (cond
    [title?
     ◊string-append{<article class="with-title hentry">
      ◊(->html `(h1 [[class "entry-title"]] ,@(get-elements title-tx)))
      <p class="time"><a href="#" class="rel-bookmark">
      <time datetime="◊published" class="published">◊ymd->english[published]</time>
      </a></p>
      <section class="entry-content">}]
    [else
     ◊string-append{<article class="no-title hentry">
      <h1><a href="#" class="rel-bookmark">