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

#lang pollen

◊; Copyright 2019 by Joel Dueck. All Rights Reserved.

◊(define-meta published "2019-04-11")

◊title{What Should People Do With Old Journals?}

When I die, I’ll leave behind a lot of ◊pin{journals} and notebooks. These may be of
interest to my immediate family, but they won’t exactly be great leisure reading. The only obvious
choices are to keep them in a box in the attic, or eventually throw them out.

A ◊def{journal} is a collection of personal observations.

There ought to be a third choice. Even the most mundane journal has great value simply because it
contains lots of historical information about current thinking, lifestyle habits, values, and events,
things which change wildly over long time periods.

◊blockquote[#:caption "hi"]{On the receiving end, suppose you inherit your great-grandfather’s journal; he has been dead for
decades and you never knew him personally. If you can find the time, you pore over it for an hour or
two, deciphering the handwriting. You learn some facts about him and how he looked at things. What
happens after that?}

I have an idea that there should be an ◊pin[#:key "archives"]{archive}, a public repository for
things like this. You could send in your great-grandfather’s journal for use by future historians.
They would digitize or transcribe it, analyze it, and tag it with metadata about who wrote it, when
they wrote it, and generally what topics they wrote about. They could allow you to specify that it
must remain private until a specified date, and provide you with a digital copy, or even a nice hard
copy if you wanted to pay a little extra.

This would give researchers a huge resource to draw upon, and allow the full value of old journals
(the sentimental ◊em{and} the historic value) to be realized, without compromising anyone’s
privacy.

#lang racket/base

(require pollen/decode

         txexpr

         yarn/markup


         yarn/string
         yarn/tools)







(provide
 (all-defined-out)
 (all-from-out yarn/markup))





(module+ setup
  (provide block-tags)



  (define block-tags blocks-elements))















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






  (define (no-linebreaks xs)
    (decode-linebreaks xs " "))
  (decode-paragraphs xs 'paragraph #:linebreak-proc no-linebreaks))


(define (root . elems)

  (validate-txexpr `(test ,@elems))
  (check-title elems)


  `(document ,@(decode-hardwrapped-paragraphs elems)))





































(define (check-title elems)
  (cond


    [(and (not (meta-set? 'title))







          ((tx-is? 'poetry #:has-attrs 'title) (car elems)))
     (set-meta 'title (format "‘~a’" (attr-ref (car elems) 'title)))
     (set-meta 'title-supplied? #t)]
    [(not (meta-set? 'title))



     (set-meta 'title (first-words elems 5))]))

#lang racket/base

; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.

;; Pollen “tag functions” that return elements of a Yarn AST. This AST can be
;; rendered into HTML or other formats (using, e.g., the yarn/render/html module).






(require pollen/decode
         pollen/tag


         "index.rkt"
         "string.rkt"
         "tools.rkt")

(provide (all-defined-out))








;; Yarn AST:

;;  (document Block-Contents)










;;  Footnote definitions, index entry keys are stored in the metas



;;  Block-Content := 

;;    (heading #:level Inline-Contents)
;;    | (paragraph Inline-Contents)
;;    | (thematic-break style)



;;    | (codeblock info Inline-Contents)

;;    | (blockquote items := (item Block-Contents))

;;    | (poetry title style Block-Contents)


;;    | (itemization style start Block-Contents)






;;    | (dialogue speeches := (speech interlocutor Block-Contents))




;;    | (figure source caption)










;;    | (margin-note Block-Contents)















;;  Inline-Content :=


;;    string?

;;    | (italic Inline-Contents)
;;    | (bold Inline-Contents)



;;    | (link destination Inline-Contents)
;;    | (monospace Inline-Contents)

;;    | (strikethrough Inline-Contents)
;;    | (caps Inline-Contents)
;;    | (image description source)

;;    | (xref type dest-key Inline-Contents)



;;    | (footnote-ref label)
;;    | line-break





(define blocks-elements






  '(heading



    paragraph
    thematic-break


    codeblock








    blockquote

    poetry


    itemization
    dialogue

    figure
    margin-note))












(define inline-elements
  '(italic


    bold

    link
    image
    xref
    footnote-ref
    line-break))




(define (title . t) (set-meta 'title t) (set-meta 'title-supplied? #t) "")

(define (section . s) `(heading [[level "2"]] ,@s))






(define (subsection . s) `(heading [[level "3"]] ,@s))
(define (excerpt . e) (set-meta 'excerpt e))
(define (excerpt* . e) (apply excerpt e) `(@ ,@e))






(define (pause [type 'blank]) `(thematic-break ,type)) ; type = blank | mark







(define codeblock (default-tag-function 'codeblock #:info ""))
(define blockquote (default-tag-function 'blockquote)) ; #:caption
(define figure (default-tag-function 'figure))




(define (i . inline) `(italic ,@inline))
(define em i)
(define (b . inline) `(bold ,@inline))








(define (mono . inline) `(monospace ,@inline))



(define (caps . inline) `(caps ,@inline))
(define (strike . inline) `(strikethrough ,@inline))

(define br 'line-break)


(define (link ref . elems) `(link ,ref ,@elems))
(define (url ref URL) (update-metas-subhash 'urls ref URL) "")




(define (xref type elems k)








  (define key (or k (normalize-key (->text elems))))




  (cons-to-metas-list 'xref-keys key)



  `(xref ,type ,key ,@elems))




(define (pin #:key [key #f] . elems) (xref 'idx elems key))



(define (def #:key [key #f] . elems) (xref 'def elems key))

(define (ref #:key [key #f] . elems) (xref 'ref elems key))











(define (fn ref) `(footnote-ref ,ref))


(define (fndef ref . elems) (update-metas-subhash 'footnote-defs ref elems) "")

(define (ol . elems) `(itemization [[start "1"]] ,@elems))     ; #:style
(define (ul . elems) `(itemization ,@elems))       ; #:style
(define (item . blocks) `(item ,@blocks))



(define (dialogue . speeches) `(dialogue ,@speeches))
(define (say interlocutor elems) `(speech ,interlocutor ,@elems))


(define (saylines interlocutor elems)











  `(speech ,interlocutor ,@(decode-linebreaks elems 'line-break)))

(define verse (default-tag-function 'poetry)) ; #:title, #:style

#lang racket/base

; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.

;; Renders a Yarn AST and metadata into HTML

(require "../tools.rkt"
         "../string.rkt"
         koyo/haml
         pollen/core
         pollen/decode
         racket/function
         racket/list
         racket/match
         racket/string
         txexpr)

(provide doc->html)

;; TODO: most of this should all go into the template code
(define (doc->html doc)
  (define-values (title-type class)
    (if (meta-set? 'title-supplied?)
        (values 'given "with-title")
        (values 'generated "no-title")))
  (haml
   (:article.h-entry
    [[:class class]]
    ,@(heading/permlink title-type)
    (:section.entry-content
     ,@(decode-elements #:block-txexpr-proc render-block
                        #:inline-txexpr-proc render-inline
                        (cdr doc))))))

;; TODO: This should really go into the template code
(define (heading/permlink title-type)
  (define m (current-metas))
  (define p (hash-ref m 'published))
  (case title-type
    [(given)
     (haml
      (:h1.entry-title ,@(hash-ref m 'title))
      (:p.time
       (:a.rel-bookmark
        [[:href (string-append "/" (here-output-path))]]
        (:time.published [[:datetime p]] (ymd->english p)))))]
    [(generated)
     (haml
      (:h1
       (:a.rel-bookmark
        [[:href (string-append "/" (here-output-path))]]
        (:time.entry-title [[:datetime p]] (ymd->english p)))))]))

;;  Block-Content := 
;;    ✅ (heading level Inline-Contents)
;;    | ✅ (paragraph Inline-Contents)
;;    | ✅ (thematic-break style)
;;    | ✅ (codeblock info Inline-Contents)
;;    | ✅ (blockquote items := (item Block-Contents))
;;    | ✅ (poetry title style Block-Contents)
;;    | ✅ (itemization style start Block-Contents)
;;    | ✅ (dialogue speeches := (speech interlocutor Block-Contents))
;;    | ✅ (figure source caption)
;;    | (margin-note Block-Contents)

(define (render-block e)
  (match e
    [(list 'heading (list (list 'level lev)) elems ...) (render-heading lev elems)]
    [(list 'paragraph elems ...) `(p ,@elems)]
    [(list 'thematic-break style) `(hr [[class ,style]])]
    [(list 'blockquote elems ...) `(blockquote ,@elems)]
    [(txexpr 'poetry attrs elems) (render-poetry attrs elems)]
    [(txexpr 'codeblock attrs elems) (render-codeblock attrs elems)]
    [(txexpr 'itemization attrs elems) (render-itemization attrs elems)]
    [(txexpr 'dialogue _ elems) `(dl ,@elems)]
    [(list 'speech interlocutor elems ...)
     `(@ (dt ,interlocutor (span [[class "x"]] ": ")) (dd ,@elems))]
    [(txexpr 'figure attrs elems) (render-figure (car elems) (cdr elems))]
    [else (raise-argument-error 'render-block "block-content" e)]))

;;  Inline-Content :=
;;    string?
;;    |  ✅ (italic Inline-Contents) 
;;    |  ✅ (bold Inline-Contents)
;;    |  ✅ (link destination Inline-Contents)
;;    |  ✅ (monospace Inline-Contents)  
;;    |  ✅ (strikethrough Inline-Contents)
;;    |  ✅ (caps Inline-Contents)
;;    | (image description source)
;;    | ✅ (xref type dest-key Inline-Contents)
;;    | ✅ (footnote-ref label)
;;    | line-break

(define (render-inline e)
  (match e
    [(list 'italic elems ...) `(i ,@elems)]
    [(list 'bold elems ...) `(b ,@elems)]
    [(list 'monospace elems ...) `(samp ,@elems)]
    [(list 'strikethrough elems ...) `(del ,@elems)]
    [(list 'caps elems ...) `(span [[class "caps"]] ,@elems)]
    [(list 'link dest elems ...) (render-link dest elems)]
    [(list 'xref type key elems ...) (render-xref type key elems)]
    [(list 'footnote-ref ref) (render-footnote-ref ref)]
    [(list 'item elems ...) `(li ,@elems)]
    [else e]))

(define (render-link dest elems)
  (define url
    (or (get-metas-subhash 'urls dest)
        (format "#Missing_Reference_~a" dest)))
  `(a [[href ,url]] ,@elems))

(define (render-heading level elems)
  (define tag (string->symbol (format "h~a" level)))
  `(,tag ,@elems))

(define (render-poetry attrs elems)
  (define title
    (match (attr-ref attrs 'title attrs #f)
      [(? string? t) `(p [[class "verse-heading"]] ,t)]
      [_ ""]))
  (define pre-attrs
    (cond
      [(string-contains? (attr-ref attrs 'style "") "italic")
       '((style "font-style: italic"))]
      [else '()]))
  `(div [[class "poem"]] ,title (pre [[class "verse"] ,@pre-attrs] ,@elems)))

(define (render-codeblock attrs elems)
  (define file (or (assoc 'filename attrs) ""))
  (define codeblock `(pre [[class "code"]] (code ,@elems)))
  (cond [(non-empty-string? file) `(@ (div [[class "listing-filename"]] 128196 " " ,file) ,codeblock)]
        [else codeblock]))

(define (render-itemization attrs elems)
  (define tag (if (attr-ref attrs 'start #f) 'ol 'ul))
  `(,tag ,attrs ,@elems))
  
(define (render-figure source elems)
  `(figure [[class "fullwidth"]]
           (img [[src ,source]] [[alt ,(->text elems)]])
           (figcaption ,@elems)))

;; The AST guarantees that they key will already be URI-safe
(define (render-xref type key elems)
  `(a [[id ,(here-key (format "_~a-~a" type key))]
       [href ,(string-append "/keyword-index.html#" key)] ; TODO: ref type links need to resolve to the target
       [data-index-entry ,key]
       [class ,(symbol->string type)]]
      ,@elems))

(define (render-footnote-ref ref)
  (cons-to-metas-list 'fn-names ref)  
  (let* ([here       (here-key)]
         [fn-names   (hash-ref (current-metas) 'fn-names)]
         [def-anchor (format "#~a_fndef_~a" here ref)]
         [nth-ref    (number->string (count (curry equal? ref) fn-names))]
         [ref-id     (format "#~a_fn_~a_~a" here ref nth-ref)]
         [fn-number  (+ 1 (index-of (remove-duplicates (reverse fn-names)) ref))]
         [ref-text   (format "(~a)" fn-number)])
    `(sup (a [[href ,def-anchor] [id ,ref-id]] ,ref-text))))

#lang racket/base

(require gregor
         racket/match
         racket/string
         txexpr)

(provide ->text
         first-words
         ymd->english)

(module+ test (require rackunit))

;; Concatenate the string elements of a txexpr or list together
(define (->text v)
  (match v
    [(txexpr _ _ elements) (->text elements)]
    [(list elements ...) (string-append* (map ->text elements))]
    [(? string? s) s]
    [_ ""]))

;; 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 (->text (car 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 [(and (char-whitespace? c) write-this-char?) (write-char #\space out)]
                   [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) (string-append words "…")]
        [(equal? '() (cdr txprs)) words]
        [else (string-append words " " (first-words (cdr 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!"))

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

#lang racket/base

(require file/sha1
         pollen/core
         pollen/file
         pollen/setup
         (only-in racket/function identity)
         racket/match
         racket/path
         racket/string
         threading
         txexpr)

(provide (all-defined-out))

;; Convert a string into all lowercase, delete all non-alphanum chars, replace spaces with ‘-’
(define (normalize-key str)
  (~> (string-downcase str)
      (regexp-replace #rx"ies$" _ "y")
      (string-trim "s" #:left? #f)
      (regexp-replace* #rx"[^A-Za-z0-9 ]" _ "")
      (string-normalize-spaces #px"\\s+" "-")))

;; ~~ Metas reference and updating ~~~~~~~~~~~~~~~

;; Computes a unique string key for the current Pollen source and stashes it in the metas
(define (here-key [suffix ""])
  (define metas (current-metas))
  (define (set-here-key!)
    (set-meta 'here-key
              (~> (hash-ref metas 'here-path)
                  string->bytes/utf-8
                  sha1-bytes
                  bytes->hex-string
                  (substring 0 8))))
  (string-append (hash-ref metas 'here-key set-here-key!) suffix))

(define (here-source-path #:string? [string? #t])
  (define proc (if string? path->string identity))
  (cond
    [(current-metas)
     (proc (find-relative-path (current-project-root) (hash-ref (current-metas) 'here-path)))]
    [else "."]))

(define (here-output-path #:string? [string? #t])
  (define proc (if string? path->string identity))
  (proc (->output-path (here-source-path #:string? #f))))

(define (meta-set? key)
  (and (hash-ref (current-metas) key #f) #t))

(define (set-meta key val)
  (current-metas (hash-set (current-metas) key val))
  val)

(define (cons-to-metas-list key val)
  (define consed (cons val (hash-ref (current-metas) key '())))
  (current-metas (hash-set (current-metas) key consed))
  consed)

(define (update-metas-subhash key subkey val [proc (λ (v) v)])
  (define metas (current-metas))
  (define subhash (hash-ref metas key hasheq))
  (set-meta key (hash-set subhash subkey (proc val))))

(define (get-metas-subhash key subkey)
  (hash-ref (hash-ref (current-metas) key #hasheq()) subkey #f))

;; Returns a function will test if a txexpr's tag matches the given symbol and
;; (optionally) contains all given attributes.
(define (tx-is? t #:has-attrs [a '()])
  (define tags (if (list? t) tags (list t)))
  (define attrs (if (list? a) a (list a)))
  (lambda (v)
    (and (txexpr? v)
         (member (get-tag v) tags)
         (andmap (λ (attr) (attrs-have-key? a attr)) attrs)
         #t)))