◊(Local Yarn Code "dust.rkt at [0d3df679]")

File dust.rkt artifact c1bae001 part of check-in 0d3df679


#lang racket/base

;; Copyright (c) 2018 Joel Dueck.
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; A copy of the License is included with this source code, in the
;; file "LICENSE.txt".
;; You may also obtain a copy of the License at
;;
;;       http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; 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 ""
         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)
  (define maybe-series (or (select-from-metas 'series (current-metas)) ""))
  (cond
    [(non-empty-string? maybe-series)
     (->pagenode (string-append series-path "/" maybe-series ".html"))]
    [else '||]))

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

(define (series-title)
  (define series-pnode (series-pagenode)) 
  (case series-pnode
    ['|| ""] ; no series specified
    [else (or (select-from-metas 'title series-pnode) "")]))

;; ~~~ Project-wide Pagetrees ~~~

(define (include-in-pagetree folder extension)
  (define (matching-file? f)
    (string-suffix? f extension))
  (define (file->output-pagenode f)
    (string->symbol (format "~a/~a" folder (string-replace f extension ".html"))))

  (define file-strs (map path->string (directory-list folder)))
  (map file->output-pagenode (filter matching-file? file-strs)))

(define articles-pagetree
  `(root ,@(include-in-pagetree articles-path ".poly.pm")))

(define series-pagetree
  `(root ,@(include-in-pagetree series-path ".poly.pm")))

;; ~~~ Convenience functions for tagged x-expressions ~~~

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

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

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