capybara/render.rkt

#lang racket/base

(require racket/list racket/match racket/port racket/pretty racket/set racket/string
         racket/runtime-path
         markdown markdown/display-xexpr markdown/toc
         "compiler.rkt" "defs.rkt" "fetch.rkt"
         threading
         (prefix-in sass: sass)
         (prefix-in mathml: "ext-mathml/main.rkt")
         (prefix-in syntax: "ext-syntax/main.rkt")
         (prefix-in page: "templates/page.html.rkt"))

(struct input-doc [metadata text] #:transparent)
(struct ir-doc [metadata html] #:transparent)

(define-runtime-path *render.scss* "render.scss")

(define (read-input-doc [port (current-input-port)])
  (define metadata (read port))
  (unless (metadata? metadata)
    (error "post front matter is not valid metadata!"))
  (define text (port->string port))
  (input-doc metadata text))

(define *xref-char* "^")
(define *user-char* "@")
(define *hashtag-char* "#")

;; transforms the xexpr into an xexpr that includes links to entities
(define (extract-text-starting-with xexpr start-char tag-name)
  (define re (pregexp (string-append start-char "(\\p{L}|\\p{N})+")))
  (define (process+ xexpr)
    (match xexpr
      ;; do not descend into other special tags
      [(list (or 'code 'math 'tech 'deftech 'masto 'user 'xref) attrs children ...) (list xexpr)]
      ;; recursive
      [(list tag attrs children ...)
       (list (cons tag (cons attrs
                       (apply append
                              (map (lambda (child) (process+ child)) children)))))]
      ;; extract and transform the prefixed text
      [(? string? str)
       (define posns (regexp-match-positions* re str))
       (define-values [items last-pos]
         (for/fold ([items '()] [last-pos 0]) ([pos (in-list posns)])
           (define value (substring str (car pos) (cdr pos)))
           (values (cons `(,tag-name ([target ,(substring value 1)]) ,value)
                         (cons (substring str last-pos (car pos)) items))
                   (cdr pos))))
       (reverse (cons (substring str last-pos) items))]))
  (first (process+ xexpr)))
(define (extract-text-starting-with/many xexprs start-char tag-name)
  (map (λ (xexpr) (extract-text-starting-with xexpr start-char tag-name)) xexprs))

;; extracts prefixed links and converts them into the <xref> pseudo-tag
(define (extract-prefixed-links xexpr start-char tag-name)
  (define (pred? s)
    (and (string? s) (> (string-length s) 1) (string=? start-char (substring s 0 1))))
  (define (extract-prefixed-links+ xexpr)
    (match xexpr
      [(list 'a attrs body ...)
       (match (assoc 'href attrs)
         [(list _ (? pred? value))
          (define target (substring value 1))
          `(,tag-name ([target ,target]) ,@(map extract-prefixed-links+ body))]
         [_ (apply list 'a attrs (map extract-prefixed-links+ body))])]
      [(list tag attrs children ...)
       (apply list tag attrs (map extract-prefixed-links+ children))]
      [(? string? str) str]))
  (extract-prefixed-links+ xexpr))
(define (extract-prefixed-links/many xexprs start-char tag-name)
  (map (λ (xexpr) (extract-prefixed-links xexpr start-char tag-name)) xexprs))

(define (input-doc->ir-doc doc)
  (match-define (input-doc md text) doc)
  (define output-raw (parse-markdown text))
  (define output-cooked
    (~> output-raw syntax:transform-xexprs mathml:transform-xexprs
        (extract-text-starting-with/many *hashtag-char* 'hashtag)
        (extract-text-starting-with/many *user-char* 'user)
        (extract-prefixed-links/many *xref-char* 'xref)
        (extract-prefixed-links/many *user-char* 'user)))
  (ir-doc md output-cooked))

;; lowers pseudo-tags into their final form
(define (lower-specials xexpr base-url)
  (define (lower-specials* xexpr)
    (match xexpr
      ;; hashtags
      [(list 'hashtag (list (list 'target target)) body ...)
       `(a ([class "hashtag"] [href ,(format "~a/hashtag/~a" base-url target)])
           ,@(map lower-specials* body))]
      ;; xrefs
      [(list 'xref (list (list 'target target)) body ...)
       `(a ([class "xref"] [href ,(format "~a/xref/~a" base-url target)])
           ,@(map lower-specials* body))]
      ;; users
      [(list 'user (list (list 'target target)) body ...)
       `(a ([class "user"] [href ,(format "~a/user/~a" base-url target)])
           ,@(map lower-specials* body))]
      ;; deftech and tech
      [(list 'deftech (list (list 'key key)) (? string? body))
       `(em ([class "deftech"] [id ,(format "tech-~a" key)]) ,body)]
      [(list 'tech (list (list 'key key)) (? string? body))
       `(a ([class "tech"] [href ,(format "~a/tech/~a" base-url key)]) ,body)]
      ;; masto
      ;; TODO
      [(list 'p _ (list 'masto _ (? string? url)))
       (masto-fetch-embed url)]
      ;; everything else
      [(list tag attrs children ...)
       (apply list tag attrs (map lower-specials* children))]
      [(? string? str) str]))
  (lower-specials* xexpr))

(define (ir-doc->page doc)
  (match-define (ir-doc md content) doc)
  (let ([content (lower-specials content "https://awoo.systems")])
    (define content-toc (toc content))

    (define document
      (page:execute
        (hash 'metadata md
              'content-toc content-toc
              'content content)))

    (with-output-to-string (λ () (display "<!doctype html>") (display-xexpr document)))))

(define (compile-index-scss index.scss)
  (define scss-files (cons *render.scss* (append mathml:scss-files syntax:scss-files)))
  (define top-level-style
    (string-join
      (cons index.scss (map (λ (x) (format "@import \"~a\";" (path->string x))) scss-files))
      "\n"))
  (sass:compile/string top-level-style #t))

(module+ main
  (require racket/cmdline)
  (command-line
    #:program "meow"
    #:args (infile outfile)
    (define-rule (scss [out "index.css"] [in "index.scss"])
      (~> (compile-index-scss (port->string in)) (write-string out)))
    (define-rule (render [out outfile] [in infile])
      (~> (read-input-doc in) input-doc->ir-doc ir-doc->page (write-string out)))
    (generate/execute (list render scss))))