274 lines
11 KiB
Racket
274 lines
11 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class racket/draw racket/fasl racket/list racket/match racket/port racket/path
|
|
racket/set racket/string racket/runtime-path net/url-string pict
|
|
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"))
|
|
|
|
(provide scan-for-rules)
|
|
|
|
(struct input-doc [metadata xref-name text] #:transparent)
|
|
(struct ir-doc [metadata xref-name html] #:prefab)
|
|
|
|
(define-runtime-path *render.scss* "render.scss")
|
|
|
|
(define *index.md* (build-path "index.md"))
|
|
(define *config.rktd* (build-path "config.rktd"))
|
|
|
|
(define *reserved-slugs* (set (build-path "hashtag") (build-path "user") (build-path "tech")))
|
|
|
|
(define (read-input-doc xref-name [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 xref-name 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 (? symbol? 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 (? symbol? 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 (check-xrefs xexprs xrefs-repo base-xref)
|
|
(define (check-xrefs-help xexpr)
|
|
(match xexpr
|
|
[(list 'xref (list (list 'target target)) body ...)
|
|
(define abs-target
|
|
(simplify-path
|
|
(url->path
|
|
(combine-url/relative
|
|
(path->url base-xref)
|
|
target))
|
|
#f))
|
|
(unless (set-member? xrefs-repo (explode-path abs-target))
|
|
(error "invalid xref!" target))
|
|
(apply list 'xref (list (list 'target (path->string abs-target)))
|
|
(map check-xrefs-help body))]
|
|
[(list (? symbol? tag) attrs body ...)
|
|
(cons tag (cons attrs (map check-xrefs-help body)))]
|
|
[(? string?) xexpr]))
|
|
(map check-xrefs-help xexprs))
|
|
|
|
(define (input-doc->ir-doc doc xrefs-repo)
|
|
(match-define (input-doc md xref-name 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)
|
|
(check-xrefs xrefs-repo xref-name)))
|
|
(ir-doc md xref-name 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~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 make this not janky
|
|
[(list 'p _ (list 'masto _ (? string? url)))
|
|
(masto-fetch-embed url)]
|
|
;; everything else
|
|
[(list (? symbol? tag) attrs children ...)
|
|
(apply list tag attrs (map lower-specials* children))]
|
|
[(? string? str) str]))
|
|
(map lower-specials* xexpr))
|
|
|
|
(define (ir-doc->page doc xrefs-repo site-config)
|
|
(match-define (ir-doc md xref-name content) doc)
|
|
(define base-url (assoc-ref+ site-config 'base))
|
|
|
|
(define exploded (explode-path xref-name))
|
|
(define exploded-length (length exploded))
|
|
|
|
(define (neighbor/immediate-child? p)
|
|
(or (= exploded-length (length p))
|
|
(and (= (add1 exploded-length) (length p))
|
|
(equal? (list-ref p (sub1 exploded-length))
|
|
(last exploded)))))
|
|
|
|
(define site-toc-defs
|
|
(for/list ([p (in-set xrefs-repo)] #:when (neighbor/immediate-child? p))
|
|
(define target (apply build-path p))
|
|
(define link (format "~a~a" base-url (path->string target)))
|
|
(define name (path->string (apply build-path (list-tail p (sub1 exploded-length)))))
|
|
(list
|
|
name
|
|
`(li () (a ([href ,link])
|
|
,(if (equal? p exploded) `(strong () ,name) name))))))
|
|
(define parent-name (simplify-path (build-path xref-name 'up) #f))
|
|
|
|
(define site-toc
|
|
`(ol ()
|
|
,@(if (equal? (build-path "/") xref-name)
|
|
'()
|
|
`((li () (a ([href ,(format "~a~a" base-url (path->string parent-name))]) "<up>"))))
|
|
,@(for/list ([def (in-list (sort site-toc-defs string<? #:key first))])
|
|
(second def))))
|
|
|
|
(let ([content (lower-specials content base-url)])
|
|
(define content-toc (toc content))
|
|
|
|
(define document
|
|
(page:execute
|
|
(hash 'metadata md
|
|
'site-config site-config
|
|
'xref-name xref-name
|
|
'base-url base-url
|
|
'site-toc site-toc
|
|
'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))
|
|
|
|
(define (scan-for-rules [output-dir (build-path "target")]
|
|
[build-dir (build-path "build")]
|
|
[src-dir (build-path "src")])
|
|
(define-rule (scss [out (build-path output-dir "index.css")]
|
|
[in (build-path src-dir "index.scss")])
|
|
(~> (compile-index-scss (port->string in)) (write-string out)))
|
|
|
|
(define favicon.rkt (build-path src-dir "favicon.png.rkt"))
|
|
(define-rule (favicon [out (build-path output-dir "favicon.png")]
|
|
[in favicon.rkt])
|
|
(define icon-pict (dynamic-require favicon.rkt 'icon-pict))
|
|
(define icon-bitmap (pict->bitmap icon-pict))
|
|
(send icon-bitmap save-file out 'png))
|
|
|
|
(struct rule-spec [src intermediate output xref-name] #:transparent)
|
|
|
|
(define rule-specs
|
|
(parameterize ([current-directory src-dir])
|
|
(for/list ([md-file (in-directory #f)]
|
|
#:when (equal? (path-get-extension md-file) #".md"))
|
|
(define fasl-file (path-replace-extension md-file #".fasl"))
|
|
(define out-file (path-replace-extension md-file #".html"))
|
|
(define xref-name
|
|
(let-values ([(base name dir?) (split-path md-file)])
|
|
(if (equal? *index.md* name)
|
|
(if (eq? 'relative base)
|
|
(build-path "/")
|
|
(build-path "/" base))
|
|
(build-path "/" (path-replace-extension md-file #"")))))
|
|
(rule-spec (build-path src-dir md-file)
|
|
(build-path build-dir fasl-file)
|
|
(build-path output-dir out-file)
|
|
xref-name))))
|
|
(define config.rktd (build-path src-dir *config.rktd*))
|
|
|
|
;; TODO : this sucks
|
|
;; we should have a radix tree
|
|
(define xrefs-repo
|
|
(for/set ([spec (in-list rule-specs)])
|
|
(define exploded (explode-path (rule-spec-xref-name spec)))
|
|
(when (and (> (length exploded) 1)
|
|
(set-member? *reserved-slugs* (second exploded)))
|
|
(error "file is using a reserved slug" (rule-spec-src spec)))
|
|
exploded))
|
|
|
|
(define intermediate-rules
|
|
(for/list ([spec (in-list rule-specs)])
|
|
(define-rule (intermediate-rule [out (rule-spec-intermediate spec)]
|
|
[in (rule-spec-src spec)])
|
|
(~> (read-input-doc (rule-spec-xref-name spec) in)
|
|
(input-doc->ir-doc xrefs-repo)
|
|
s-exp->fasl (write-bytes out)))
|
|
intermediate-rule))
|
|
|
|
(define output-rules
|
|
(for/list ([spec (in-list rule-specs)])
|
|
(define-rule (output-rule [out (rule-spec-output spec)]
|
|
[in (rule-spec-intermediate spec)]
|
|
[config-in config.rktd])
|
|
(define config (read config-in))
|
|
(unless (config? config)
|
|
(error "invalid config in config.rktd!"))
|
|
(~> (port->bytes in) fasl->s-exp
|
|
(ir-doc->page xrefs-repo config)
|
|
(write-string out)))
|
|
output-rule))
|
|
(append intermediate-rules output-rules (list scss favicon)))
|
|
|
|
(module+ main
|
|
(require racket/cmdline)
|
|
(command-line
|
|
#:program "capybara-render"
|
|
#:args ()
|
|
(generate/execute (scan-for-rules))))
|