From 6d24b2fbd8102e1b463cca7da68e8e44a5f6821f Mon Sep 17 00:00:00 2001 From: haskal Date: Mon, 7 Jun 2021 05:09:20 -0400 Subject: [PATCH] implement intermediate doc format --- defs.rkt | 21 ++++++ render.rkt | 129 ++++++++++++++++++++++++++----------- templates/article.html.rkt | 2 +- xtemplate.rkt | 4 +- 4 files changed, 117 insertions(+), 39 deletions(-) create mode 100644 defs.rkt diff --git a/defs.rkt b/defs.rkt new file mode 100644 index 0000000..b2ada9f --- /dev/null +++ b/defs.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(require racket/contract racket/list racket/match) + +(provide metadata? metadata-ref metadata-ref+) + +(define metadata? + (listof (or/c + (list/c 'date integer? integer? integer?) + (list/c 'title string?) + (list/c 'slug string?) + (list/c 'summary string?) + (cons/c 'authors (listof string?))))) + +(define (metadata-ref md key [default (λ () (error "no such key"))]) + (match (assoc key md) + [#f (if (procedure? default) (default) default)] + [(cons _ rst) rst])) + +(define (metadata-ref+ md key [default (λ () (error "no such key"))]) + (first (metadata-ref md key default))) diff --git a/render.rkt b/render.rkt index 7ec18eb..fa703a1 100644 --- a/render.rkt +++ b/render.rkt @@ -1,64 +1,119 @@ #lang racket/base -(require racket/contract racket/list racket/match racket/port racket/string +(require racket/list racket/match racket/port racket/set racket/string markdown markdown/display-xexpr markdown/toc - "compiler.rkt" + "compiler.rkt" "defs.rkt" + threading (prefix-in sass: sass) (prefix-in mathml: "ext-mathml/main.rkt") (prefix-in syntax: "ext-syntax/main.rkt") (prefix-in article: "templates/article.html.rkt")) -(define metadata? - (listof (or/c - (list/c 'date integer? integer? integer?) - (list/c 'title string?) - (list/c 'slug string?) - (list/c 'summary string?) - (cons/c 'authors (listof string?))))) +(struct input-doc [metadata text] #:transparent) +(struct ir-doc [metadata hashtags html] #:transparent) -(define (metadata-ref md key [default (λ () (error "no such key"))]) - (match (assoc key md) - [#f (if (procedure? default) (default) default)] - [(cons _ rst) rst])) - -(define (metadata-ref+ md key [default (λ () (error "no such key"))]) - (first (metadata-ref md key default))) - -(struct input-document [metadata text] #:transparent) - -(define (read-doc [port (current-input-port)]) +(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-document metadata text)) + (input-doc metadata text)) -(define (markdown->html input) - (match-define (input-document md text) input) +;; transforms the xexpr into an xexpr that includes links to hashtags +(define (extract-hashtags xexpr) + (define hashtags (mutable-set)) + (define (process+ xexpr) + (match xexpr + ;; do not descend into code or math + [(list (or 'code 'math) 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 hashtags + [(? string? str) + (define posns (regexp-match-positions* #px"#(\\p{L}|\\p{N})+" str)) + (define-values [items last-pos] + (for/fold ([items '()] [last-pos 0]) ([pos (in-list posns)]) + (define hashtag (substring str (car pos) (cdr pos))) + (set-add! hashtags hashtag) + (values (cons `(hashtag () ,hashtag) + (cons (substring str last-pos (car pos)) items)) + (cdr pos)))) + (reverse (cons (substring str last-pos) items))])) + (values (first (process+ xexpr)) hashtags)) + +;; xref links start with ^ +(define (xref-link? x) + (and (string? x) (> (string-length x) 1) (char=? (string-ref x 0) #\^))) + +;; extracts xref-prefixed links and converts them into the pseudo-tag +(define (extract-xrefs xexpr) + (match xexpr + [(list 'a attrs body ...) + (match (assoc 'href attrs) + [(list _ (? xref-link? xref)) + (define target (substring xref 1)) + `(xref ([target ,target]) ,@(map extract-xrefs body))] + [_ (apply list 'a attrs (map extract-xrefs body))])] + [(list tag attrs children ...) + (apply list tag attrs (map extract-xrefs children))] + [(? string? str) str])) + +(define (input-doc->ir-doc doc) + (match-define (input-doc md text) doc) (define output-raw (parse-markdown text)) (define output-cooked (mathml:transform-xexprs (syntax:transform-xexprs output-raw))) - (define output-toc (toc output-cooked)) + (let-values ([(output-cooked hashtags) (extract-hashtags output-cooked)]) + (let ([output-cooked (extract-xrefs output-cooked)]) + (ir-doc md hashtags output-cooked)))) +;; lowers pseudo-tags into their final form +(define (lower-specials xexpr base-url) + (define (lower-specials* xexpr) + (match xexpr + ;; hashtags + [(list 'hashtag _ hashtag) + `(a ([class "hashtag"] + [href ,(string-append base-url "/tag/" (substring hashtag 1))]) + ,hashtag)] + ;; xrefs + [(list 'xref (list (list 'target target)) body ...) + `(a ([class "xref"] [href ,(string-append base-url "/xref/" target)]) + ,@(map lower-specials* body))] + ;; 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 hashtags content) doc) + (let ([content (lower-specials content "https://awoo.systems")]) + (define content-toc (toc content)) + + (define document + (article:execute + (hash 'metadata md + 'content-toc content-toc + 'content content))) + + (with-output-to-string (λ () (display "") (display-xexpr document))))) + +(define (compile-index-scss) (define scss-files (append mathml:scss-files syntax:scss-files)) (define top-level-style (string-join (map (λ (x) (format "@import \"~a\";" (path->string x))) scss-files) "\n")) - (define styles (sass:compile/string top-level-style #t)) - - (define document - (article:execute (hash 'metadata-ref metadata-ref - 'metadata-ref+ metadata-ref+ - 'metadata md - 'page-styles styles - 'content-toc output-toc - 'content output-cooked))) - - (with-output-to-string (λ () (display "") (display-xexpr document)))) + (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"]) + (~> (compile-index-scss) (write-string out))) (define-rule (render [out outfile] [in infile]) - (write-string (markdown->html (read-doc in)) out)) - (generate/execute (list render)))) + (~> (read-input-doc in) input-doc->ir-doc ir-doc->page (write-string out))) + (generate/execute (list render scss)))) diff --git a/templates/article.html.rkt b/templates/article.html.rkt index adbbcc5..318091d 100644 --- a/templates/article.html.rkt +++ b/templates/article.html.rkt @@ -26,7 +26,7 @@ (~r dn #:min-width 2 #:pad-string "0"))])))]) (meta ([name "generator"] [content "meow meow meow meow"])) ; - (style ([type "text/css"]) ,page-styles)) + (link ([rel "stylesheet"] [type "text/css"] [href "index.css"]))) (body () (nav diff --git a/xtemplate.rkt b/xtemplate.rkt index 3786f55..5333e7a 100644 --- a/xtemplate.rkt +++ b/xtemplate.rkt @@ -1,12 +1,14 @@ #lang racket/base (require racket/base racket/format racket/list racket/match racket/string + "defs.rkt" syntax/parse syntax/parse/define racket/stxparam (for-syntax racket/base racket/match racket/set)) (provide (rename-out [x:#%module-begin #%module-begin] [x:#%top #%top]) - (except-out (all-from-out racket/base racket/format racket/list racket/match racket/string) + (except-out (all-from-out racket/base racket/format racket/list racket/match racket/string + "defs.rkt") #%module-begin #%top)) (define-syntax-parameter template-id #f)