Local Yarn Code

Check-in [de9f1215]
Overview
Comment:Add support for Notes, closing [ce23bb4086]. The old dates.rkt is now dust.rkt: helper functions for use everywhere. Functions returning HTML strings have html$ prefix.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: de9f12152b1c9cec85bb7b3a2e679d31ffdfd5a67e13a81d80c31561616d7de9
User & Date: joel on 2018-09-19 19:04:38
Other Links: manifest | tags
References
2018-09-19
19:08 Closed ticket [ce23bb]: Implement markup and styles for Notes plus 4 other changes artifact: 1437a04e user: joel
Context
2018-09-19
19:13
Remove debugging call check-in: 06f21d86 user: joel tags: trunk
19:04
Add support for Notes, closing [ce23bb4086]. The old dates.rkt is now dust.rkt: helper functions for use everywhere. Functions returning HTML strings have html$ prefix. check-in: de9f1215 user: joel tags: trunk
2018-09-02
21:04
Add Flammarion engraving to home.wiki check-in: 4ec64ff2 user: joel tags: trunk
Changes

Modified crystalize.rkt from [c9502c11] to [29b5c625].

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




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


;; will be coming from me.

(require pollen/setup
         pollen/core
         pollen/template
         pollen/pagetree
         racket/string

         "sqlite-tools.rkt"
         "template-html.rkt"
         "dates.rkt")

;; ~~~ Provides ~~~

(provide spell-of-summoning!
         crystalize-article!)

;; ~~~ Private use ~~~

(define DBFILE (build-path (current-project-root) "vitreous.sqlite"))






(define table_articles-fields
  '(pagenode
    title

    published
    updated
    doc_html
    author
    conceal
    series_pagenode
    noun_singular 
    note_count))







(define table_notes-fields
  '(pagenode
    note-id
    heading
    author

    date




    note_html))

(define table_series-fields
  '(pagenode
    title
    published
    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))

(define (optional-meta m)
  (or (select-from-metas m (current-metas)) ""))

(define (series-noun)
  (define series-pagenode (->pagenode (or (select-from-metas 'series (current-metas)) "")))
  (case series-pagenode
    ['|| ""] ; no series specified
    [else (or (select-from-metas 'noun-singular series-pagenode) "")]))


;; ~~~ 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 (using current-doc and current-metas) and its notes (if any)
;; to the database, and return the rendered HTML.
;;
(define (crystalize-article! pagenode doc)








  (define header (html-article-header))
  (define footer (html-article-footer))
  (define body (->html (cdr doc)))
  ;; TK: store notes separately

  (define saving-query (make-insert/replace-query 'articles table_articles-fields))
  (query! saving-query




          (symbol->string pagenode)
          (optional-meta 'title)
          (select-from-metas 'published (current-metas))



          (optional-meta 'updated)
          (string-append header body footer)
          (optional-meta 'author)
          (optional-meta 'conceal)
          (optional-meta 'series)
          (series-noun)




























































          0) ; note_count









          
  `(@ ,header ,body ,footer))


















>


|










>
>
>
>
>


|
>


<




|
>
>
>
>
>
>



|
|

>

>
>
>
>
|









|


|
|
<
<
<
<
<
<
>









|
|


>
>
>
>
>
>
>
>
|
|
<
<
|
<
<
>
>
>
>
|
<
<
>
>
>
|
<
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
<
>
>
>
>
>
>
>
>
|
>
>
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
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
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
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
219
220
221
;; will be coming from me.

(require pollen/setup
         pollen/core
         pollen/template
         pollen/pagetree
         racket/string
         txexpr
         "sqlite-tools.rkt"
         "template-html.rkt"
         "dust.rkt")

;; ~~~ Provides ~~~

(provide spell-of-summoning!
         crystalize-article!)

;; ~~~ Private use ~~~

(define DBFILE (build-path (current-project-root) "vitreous.sqlite"))

;; Since the DB exists to serve as a high-speed cache, the tables are constructed so that
;; the most commonly needed data can be grabbed quickly with extremely simple queries. In
;; the even that you want to do something fancy and custom rather than using the pre-cooked
;; HTML, enough info is provided in the other columns to allow you to do so.
;;
(define table_articles-fields
  '(pagenode
    title_plain
    title_html_flow
    published
    updated

    author
    conceal
    series_pagenode
    noun_singular 
    note_count
    doc_html
    disposition
    disposition_note_id
    listing_full_html    ; Contains full content in default HTML format, but without notes
    listing_excerpt_html ; Not used for now
    listing_short_html)) ; Date and title only

(define table_notes-fields
  '(pagenode
    note_id
    title_html_flow
    author
    author_url
    date
    disposition
    content_html
    listing_full_html
    listing_excerpt_html  ; Not used for now
    listing_short_html))

(define table_series-fields
  '(pagenode
    title
    published
    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))

(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-values (title-plain title-html-flow)
    (make-article-titles (maybe-meta 'title (default-title pubdate)) (report disposition)))
  (define header (html$-article-open title-html-flow pubdate))
  (define footer (html$-article-close))


  


  (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
          pubdate
          (maybe-meta 'updated)

          (maybe-meta 'author default-authorname)
          (maybe-meta 'conceal)
          (maybe-meta 'series)
          (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})

(define (make-article-titles title-val disposition)
  (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))]))
  
(define (crystalize-notes! pagenode parent-title note-txprs)
  (define (crystalizer note-tx)
    (crystalize-note! note-tx (symbol->string pagenode) parent-title))
  
  (cond [((length note-txprs) . > . 0)
         (define notes-html (map crystalizer note-txprs))
         (html$-notes-section notes-html)]
        [else ""]))

(define (crystalize-note! note-tx pagenode parent-title-plain)
  (define-values (_ attrs elems) (txexpr->values note-tx))
  (define disposition-attr (maybe-attr 'disposition attrs))
  (define note-date (maybe-attr 'date attrs))
  
  ;; Check required attributes
  (unless (non-empty-string? note-date)
    (raise-arguments-error 'note "required attr missing: date" "attrs" attrs))
  (unless (or (string=? "" disposition-attr)
              (and ((length (string-split disposition-attr)) . >= . 2)))
    (raise-arguments-error 'note
                           "must be in format \"[symbol] [past-tense-verb]\""
                           "disposition attr"
                           disposition-attr))
  
  ;; Parse out remaining columns
  (define author (maybe-attr 'author attrs))
  (define note-id (build-note-id note-tx))
  (define title-html-flow (html$-note-title author pagenode parent-title-plain))
  (define author-url (maybe-attr 'author-url attrs))
  (define-values (disp-mark disp-verb) (disposition-values disposition-attr))
  (define content-html (html$-note-contents disp-mark (get-elements note-tx)))
  (define listing-full-html
    (html$-note-listing-full pagenode note-id title-html-flow note-date author author-url content-html))

  (define note-record
    (list pagenode
          note-id
          title-html-flow
          author
          author-url
          note-date
          disposition-attr
          content-html
          listing-full-html
          "" ; listing_excerpt_html: Not used for now
          "")) ; listing_short_html: Not used for now
  

  ;; save to db
  (define save-note-query
    (format (string-append "INSERT OR REPLACE INTO `notes` (`rowid`, ~a) "
                           "VALUES ((SELECT `rowid` FROM `notes` WHERE `pagenode` = ?1"
                           " AND `note_id` = ?2), ~a)")
            (list->sql-fields table_notes-fields)
            (list->sql-parameters table_notes-fields)))
  (apply query! save-note-query note-record)
  
  ;; return html$ of note
  (html$-note-in-article note-id note-date author author-url content-html))

Modified dust.rkt from [46a355ed] to [a49e4077].

17
18
19
20
21
22
23
24






25















































26























27



28
29









30


31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
;; limitations under the License.
;;
;; Author contact information:
;;   joel@jdueck.net
;;   https://joeldueck.com
;; -------------------------------------------------------------------------

;; Convenience functions for YYYY-MM-DD date strings






















































(require gregor























         racket/string)




(provide (all-defined-out))












;; These functions ignore everything after the first space!
(define (ymd->dateformat ymd-string dateformat)
  (~t (iso8601->date (car (string-split ymd-string))) dateformat))

(define (ymd->english ymd-string)
  (ymd->dateformat ymd-string "MMMM d, yyyy"))

(module+ test
  (require rackunit)
  (check-equal? (ymd->english "2018-08-12") "August 12, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "d MMM YYYY") "12 Aug 2018")

  ;; How we handle weird input
  (check-equal? (ymd->english "2018-08-12 everything after 1st space ignored") "August 12, 2018")
  (check-equal? (ymd->english "2018-08 omitting the day") "August 1, 2018")
  (check-equal? (ymd->english "2018 omitting month and day") "January 1, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "123") "123")

  ;; Stuff we just don't handle
  (check-exn exn:gregor:parse? (lambda () (ymd->english "2018-xyz"))))







|
>
>
>
>
>
>

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

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







<











17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
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
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
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
;; limitations under the License.
;;
;; Author contact information:
;;   joel@jdueck.net
;;   https://joeldueck.com
;; -------------------------------------------------------------------------

(require pollen/core
         pollen/pagetree
         net/uri-codec
         gregor
         txexpr
         racket/list
         racket/string)

;; 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 ""
         attr-present?  ; Test if an attribute is present
         disposition-values
         ymd->english
         ymd->dateformat
         default-authorname
         default-title
         tx-strs
         build-note-id
         notes->last-disposition-values
         )

(define default-authorname "Joel Dueck")

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

(define (series-noun)
  (define series-pagenode (->pagenode (or (select-from-metas 'series (current-metas)) "")))
  (case series-pagenode
    ['|| ""] ; no series specified
    [else (or (select-from-metas 'noun-singular series-pagenode) "")]))

(define (attr-present? name attrs)
  (for/or ([attr-pair (in-list attrs)])
          (equal? name (car attr-pair))))

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

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

;; The format of a note’s ID is “HTML-driven” (used as an anchor link) but is included
;; here since it also serves as a primary key in the DB.
(define (build-note-id txpr)
  (string-append "#"
                 (maybe-attr 'date (get-attrs txpr))
                 "_"
                 (uri-encode (maybe-attr 'author (get-attrs txpr) default-authorname))))


;; Extract the last disposition (if any), and the ID of the disposing note, out of a list of notes
(define (notes->last-disposition-values txprs)
  (define (contains-disposition? tx) (attr-present? 'disposition (get-attrs tx)))
  (define disp-notes (filter contains-disposition? txprs))
  (cond [(not (empty? disp-notes))
         (define latest-disposition-note (last disp-notes))
         (values (attr-ref latest-disposition-note 'disposition)
                 (build-note-id latest-disposition-note))]
        [else (values "" "")]))
        
;; ~~~ Convenience functions for YYYY-MM-DD date strings ~~~

;; These functions ignore everything after the first space in the input!
(define (ymd->dateformat ymd-string dateformat)
  (~t (iso8601->date (car (string-split ymd-string))) dateformat))

(define (ymd->english ymd-string)
  (ymd->dateformat ymd-string "MMMM d, yyyy"))

(module+ test

  (check-equal? (ymd->english "2018-08-12") "August 12, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "d MMM YYYY") "12 Aug 2018")

  ;; How we handle weird input
  (check-equal? (ymd->english "2018-08-12 everything after 1st space ignored") "August 12, 2018")
  (check-equal? (ymd->english "2018-08 omitting the day") "August 1, 2018")
  (check-equal? (ymd->english "2018 omitting month and day") "January 1, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "123") "123")

  ;; Stuff we just don't handle
  (check-exn exn:gregor:parse? (lambda () (ymd->english "2018-xyz"))))

Modified pollen.rkt from [8a4112bd] to [3ae0eb3e].

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
(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"
                               "template-html.rkt"
                               "dates.rkt"
                               "crystalize.rkt"))))

;; Macro for defining tag functions that automatically branch based on the 
;; current output format and the list of poly-targets in the setup module.
;; 
(define-syntax (poly-branch-tag stx)
  (syntax-parse stx







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
(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"
                               "template-html.rkt"
                               "dust.rkt"
                               "crystalize.rkt"))))

;; Macro for defining tag functions that automatically branch based on the 
;; current output format and the list of poly-targets in the setup module.
;; 
(define-syntax (poly-branch-tag stx)
  (syntax-parse stx

Modified tags-html.rkt from [ebae6f02] to [f673367b].

24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
;; Tag functions used by pollen.rkt when HTML is the output format.

(require (for-syntax racket/base racket/syntax))
(require racket/list
         racket/function
         pollen/decode
         pollen/tag
         txexpr)


(provide html-fn
         html-fndef)

;; Customized paragraph decoder replaces single newlines within paragraphs
;; with single spaces instead of <br> tags. Allows for “semantic line wrapping”.
(define (decode-hardwrapped-paragraphs xs)







|
>







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
;; Tag functions used by pollen.rkt when HTML is the output format.

(require (for-syntax racket/base racket/syntax))
(require racket/list
         racket/function
         pollen/decode
         pollen/tag
         txexpr
         "dust.rkt")

(provide html-fn
         html-fndef)

;; Customized paragraph decoder replaces single newlines within paragraphs
;; with single spaces instead of <br> tags. Allows for “semantic line wrapping”.
(define (decode-hardwrapped-paragraphs xs)

Modified template-html.rkt from [c19af359] to [7a13118b].

19
20
21
22
23
24
25




26
27
28










29
30

31
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
70
71







































































;; Author contact information:
;;   joel@jdueck.net
;;   https://joeldueck.com
;; -------------------------------------------------------------------------

;; Provides functions for displaying content in HTML templates.
(require pollen/core




         "dates.rkt")

(provide (all-defined-out))











(define (html-head [title #f])

  ◊@{<head>
     <title>The Local Yarn◊when/splice[title]{: ◊title}</title>
     <meta charset="utf-8" />
     <meta name="viewport" content="width=device-width, initial-scale=1">
     <link rel="stylesheet" type="text/css" href="/web-extra/martin.css">
     </head>})

(define (html-page-top)
  ◊@{<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-header)
  (define title (select-from-metas 'title (current-metas)))

  (define published (select-from-metas 'published (current-metas)))
    (cond
      [title
       ◊string-append{<article class="with-title hentry">
          <h1 class="entry-title">◊|title|</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">
          <time datetime="◊published" class="entry-title">◊ymd->english[published]</time>
          </a></h1>
          <section class="entry-content">}]))

(define (html-article-footer)
  ◊string-append{</section>
     <footer class="article-info"><span class="x">(</span>Part of ‘Talking About Poetry’. Once I threw a mudball at a birdhouse. I’m not exactly proud of it, though.<span class="x">)</span></footer>
     </article>})


(define (html-page-bottom)
  ◊@{<footer>By Joel Dueck</footer>
     </main></body>})














































































>
>
>
>
|

<
>
>
>
>
>
>
>
>
>
>

|
>
|
|
|
|
|
|

|
|
|
|
|
|

<
<
>

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

|

|
|
|

|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
19
20
21
22
23
24
25
26
27
28
29
30
31

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
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
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
;; Author contact information:
;;   joel@jdueck.net
;;   https://joeldueck.com
;; -------------------------------------------------------------------------

;; Provides functions for displaying content in HTML templates.
(require pollen/core
         pollen/template
         racket/string
         txexpr
         openssl/sha1
         "dust.rkt")


(provide html$-page-head
         html$-page-body-open
         html$-article-open
         html$-article-close
         html$-page-body-close
         html$-note-title
         html$-note-contents
         html$-note-listing-full
         html$-note-in-article
         html$-notes-section)

(define (html$-page-head [title #f])
  (define title-part (if title (format ": ~a" title) ""))string-append{<head>
 <title>The Local Yarn◊|title|</title>
 <meta charset="utf-8" />
 <meta name="viewport" content="width=device-width, initial-scale=1">
 <link rel="stylesheet" type="text/css" href="/web-extra/martin.css">
 </head>})

(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-html-flow published)
  (define published (select-from-metas 'published (current-metas)))
  (cond
    [title-html-flow
     ◊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">
      <time datetime="◊published" class="entry-title">◊ymd->english[published]</time>
      </a></h1>
      <section class="entry-content">}]))

(define (html$-article-close)
  ◊string-append{</section>
 <footer class="article-info"><span class="x">(</span>Part of ‘Talking About Poetry’. Once I threw a mudball at a birdhouse. I’m not exactly proud of it, though.<span class="x">)</span></footer>
 </article>})
 

(define (html$-page-body-close)
  ◊string-append{<footer>By Joel Dueck</footer>
 </main></body>})

;; Notes
;;
(define (html$-note-title author pagenode parent-title)
  (define author-part
    (cond [(and (non-empty-string? author)
                (not (string-ci=? author default-authorname)))
           (format "A note from ~a, " author)]
          [else ""]))
  (define article-part
    (format "Re: <a class=\"cross-reference\" href=\"/~a\">~a</a>"
            pagenode
            parent-title))
  (string-append author-part article-part))

(define (html$-note-contents disposition-mark elems)
  (define-values (first-tag first-attrs first-elems) (txexpr->values (car elems)))
  (define disposition
    (cond [(non-empty-string? disposition-mark)
           `(span [[class "disposition-mark"]] ,disposition-mark)]
          [else ""]))
  (define body-elems
    (cond
      [(equal? 'p first-tag)
       (cons (txexpr 'p first-attrs (cons disposition first-elems)) (cdr elems))]
      [else
       (cons disposition elems)]))
  (string-append* (map ->html body-elems)))

(define (html$-note-listing-full pagenode note-id title-html-flow date author author-url contents)
  (define author-part
    (cond [(non-empty-string? author)
           ◊string-append{
            <div class="note-meta">
            &mdash;<a class="u-author h-card" href="◊|author-url|">◊|author|</a>
            </div>}]
          [else ◊string-append{
            <div class="note-meta">
            &mdash;<a class="u-author h-card" href="https://thelocalyarn.com">◊|default-authorname|</a>
            </div>}]))
  
  ◊string-append{
 <article class="with-title hentry">
 <h1 class="entry-title">◊|title-html-flow|</h1>
 <p class="time"><a href="◊|pagenode|◊note-id" class="rel-bookmark note-permlink">
 <time datetime="◊date">◊ymd->english[date]</time>
 </a></p>
 <section class="entry-content">
 <div class="p-content p-name">◊|contents|</div>
 ◊author-part
 </section>
 </article>})

(define (html$-note-in-article id date author author-url contents)
  ◊string-append{
 <div class="note u-comment" id="◊|id|">
 <h3><a href="◊|id|"><time class="dt-published" datetime="◊date">◊ymd->english[date]</time>
 </a></h3>
 <div class="p-content p-name">
 ◊contents
 </div>
 <div class="note-meta">
 &mdash;<a class="u-author h-card" href="◊|author-url|">◊|author|</a>
 </div>
 </div>})

(define (html$-notes-section note-htmls)
  ◊string-append{<div class="further-notes">
 <h2>Further Notes</h2>
 ◊(apply string-append note-htmls)
 </div>})

Modified template.html.p from [e6133aaa] to [b0e9b3b5].

1
2
3
4
5
6
7
8
9
10
11
12
13
<!DOCTYPE html>
<html>
◊html-head[(select-from-metas 'title here)]

◊html-page-top[]

◊spell-of-summoning![]
◊crystalize-article![here doc]

◊html-page-bottom[]

</html>



|

|




|



1
2
3
4
5
6
7
8
9
10
11
12
13
<!DOCTYPE html>
<html>
◊html$-page-head[(select-from-metas 'title here)]

◊html$-page-body-open[]

◊spell-of-summoning![]
◊crystalize-article![here doc]

◊html$-page-body-close[]

</html>

Modified web-extra/martin.css.pp from [0f5d5375] to [2a8d5a40].

445
446
447
448
449
450
451

































452
453
454
455
456
457
458
...
630
631
632
633
634
635
636















637
638
639
640
641
642
643
        width: 75%;
        text-align: left;
    }

    section.footnotes ol {
        margin: ◊x-lineheight[0.5] 0 0 0;
    }


































    /* ******* (Mobile first) Journal View styling *******
     */
    section.article-listing h2 {
        font-weight: normal; 
        font-style: italic; 
        font-size: ◊x-lineheight[1]; 
................................................................................
            grid-area: main;
        }
        section.entry-content figure figcaption {
            grid-area: margin;
            text-align: right;
            align-self: end;
        }
















        /* ******* (Grid support) Journal View styling *******
         */

        section.article-listing {
            display: grid;
            grid-template-columns: 8rem 7fr 1fr;







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







 







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







445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
...
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
        width: 75%;
        text-align: left;
    }

    section.footnotes ol {
        margin: ◊x-lineheight[0.5] 0 0 0;
    }

    /* ******* “Further Notes” added to articles ********
     */

    div.further-notes {
        margin-top: ◊x-lineheight[3];
    }

    div.further-notes>h2 {
        font-style: normal;
        font-feature-settings: "smcp" on;
        border-top: solid 2px ◊color-bodytext;
        text-transform: lowercase;
    }

    div.note h3 {
        margin-top: 0;
        font-size: 1rem;
        font-weight: normal;
        font-style: italic;
    }

    div.note-meta {
        margin-top: ◊x-lineheight[1];
        font-feature-settings: "smcp" on;
        color: #888;
    }

    span.disposition-mark {
        color: ◊color-xrefmark;
        display: inline-block;
        width: 1em;
    }

    /* ******* (Mobile first) Journal View styling *******
     */
    section.article-listing h2 {
        font-weight: normal; 
        font-style: italic; 
        font-size: ◊x-lineheight[1]; 
................................................................................
            grid-area: main;
        }
        section.entry-content figure figcaption {
            grid-area: margin;
            text-align: right;
            align-self: end;
        }

        /* ******* (Grid support) “Further Notes” added to articles *******
         */

        div.further-notes>h2 {
            width: calc(100% + 8rem);
            margin-left: -8rem;
        }

        div.note h3 {
            float: left;
            margin-left: -8rem;
            width: 7rem;
            text-align: right;
        }

        /* ******* (Grid support) Journal View styling *******
         */

        section.article-listing {
            display: grid;
            grid-template-columns: 8rem 7fr 1fr;