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

#lang racket/base



(require yarn/markup)



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

(module+ setup
  (provide block-tags)
  (define block-tags blocks-elements))

#lang info

(define collection "yarn")
(define version "0.9")

(define pkg-desc "implementation part of \"yarn\"")
(define license 'BlueOak-1.0.0)
(define deps '("base"
               "pollen"
               "threading-lib"
               "txexpr"))

#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
         racket/string
         txexpr
         "index.rkt"
         "string.rkt"
         "tools.rkt"
         yarn/path)

(provide (all-defined-out))

(define (root . elems)
  (print (validate-txexpr `(test ,@elems)))
  (check-title elems)
  (serialize-article-placeholder)
  `(document ,@(decode-hardwrapped-paragraphs elems)))

;; Customized paragraph decoder replaces single newlines within paragraphs
;; with single spaces instead of <br> tags (allow hard-wrapped paragraphs)
(define (decode-hardwrapped-paragraphs xs)
  (define (no-linebreaks xs)
    (decode-linebreaks xs " "))
  (decode-paragraphs xs 'paragraph #:linebreak-proc no-linebreaks))

;; Set a title if not already set
(define (check-title elems)
  (cond
    [(and (not (meta-set? 'title))
          (pair? elems)
          ((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 (if (pair? elems) (first-words elems 5) ""))]))

;; Yarn AST:
;;  (document Block-Contents)
;;  Footnote definitions, index entry keys are stored in the metas

;;  Block-Content := 
;;    (heading #:level Inline-Contents)
;;    | (paragraph Inline-Contents)

(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

(define-tag-function (note attrs elems)
  (let* ([note-count (update-meta 'note-count add1 0)]
         [note-id    (string-append (attr-ref attrs 'date) (format "_~a" note-count))]
         [maybe-disp (string-split (attr-ref attrs 'disposition ""))]
         [the-note (attr-set* `(note ,attrs ,@elems) 'id note-id 'parent (here-output-path))])
    (cond
      [(> (length maybe-disp) 1)
       (set-meta 'disposition `(,(car maybe-disp)
                                ,(string-join (cdr maybe-disp))
                                ,note-id))])
    (cons-to-metas-list 'notes the-note)
    (serialize-note the-note note-count)
    ""))

#lang racket/base

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

(require pollen/core
         pollen/file
         pollen/setup
         racket/path)

(provide here-source-path
         here-output-path)

(define (identity v) v)

;; Return the path to the current Pollen source, relative to project root
(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 "."]))

;; Return the path to the output filename for the current Pollen source,
;; relative to project root
(define (here-output-path #:string? [string? #t])
  (define proc (if string? path->string identity))
  (proc (->output-path (here-source-path #:string? #f))))

#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"
         "../path.rkt"
         koyo/haml
         pollen/core
         pollen/decode
         racket/function
         racket/list
         racket/match
         racket/string

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

    [(? 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 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 (first-words txprs words-needed)
  (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))

#lang racket/base

(require file/sha1
         pollen/core



         racket/file
         racket/list
         racket/string
         threading
         txexpr)

(provide (all-defined-out))

;; Convert a string into all lowercase, delete all non-alphanum chars, replace spaces with ‘-’

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







;;



;; Meta tools ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(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 (update-meta key proc default)
  (let ([updated (proc (hash-ref (current-metas) key default))])
    (set-meta key updated)))

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

;; “Notes”, in addition to being attached to/contained in articles, are also
;; shown alongside articles in the chronological feed. To make building this
;; mixed chronological feed faster, articles and notes create files in a
;; “serialize” subfolder at compile time:
;;   * The filenames are prefixed with the thing’s YMD date.
;;   * Note-files contain a datum of the entire note.
;;   * Article-files contain only the path to the article’s source.
;; 
;; This way building the chrono feed is simple and doesn’t require loading
;; and sorting the docs/metas of the entire article set.

(define serialize-folder "compiled/.serialized")

(define (current-serialize-folder-path)
  (and~> (hash-ref (current-metas) 'here-path #f)
         explode-path
         (drop-right 1)
         (append (list serialize-folder))
         (apply build-path _)))

;; 
;; TODO: Possible speed gains by spawning a thread to do this
(define (serialize-article-placeholder)
  (let* ([ser-folder (current-serialize-folder-path)]
         [filename (format "~a.article" (hash-ref (current-metas) 'published))]
         [placeholder (build-path ser-folder filename)])
    (unless (directory-exists? ser-folder) (make-directory ser-folder))
    (unless (file-exists? placeholder)
      (write-to-file (hash-ref (current-metas) 'here-path)
                     (build-path ser-folder filename)
                     #:exists 'truncate))))

(define (serialize-note note num)
  (let ([ser-folder (current-serialize-folder-path)]
        [filename (format "~a_~a.note" (attr-ref note 'date) num)])
    (unless (directory-exists? ser-folder) (make-directory ser-folder))
    (write-to-file note (build-path ser-folder filename) #:exists 'truncate)))