add xexpr templating system

ext-mathml/main.rkt

@@ -18,8 +18,8 @@
     (subprocess #f #f #f "/usr/bin/env" "node" (path->string *js-path*)))
   (define out-str #f)
   (define err-str "")
-  (define out-reader (thread (lambda () (set! out-str (port->string out)))))
-  (define err-reader (thread (lambda () (set! err-str (port->string err)))))
+  (define out-reader (thread (λ () (set! out-str (port->string out)))))
+  (define err-reader (thread (λ () (set! err-str (port->string err)))))
 
   (write-string source in)
   (flush-output in)
@@ -38,7 +38,7 @@
 
   (match-define (list 'math attrs bodies ...) (string->xexpr out-str))
   `(math ,(cons (list 'display (if block? "block" "inline"))
-                (filter (lambda (x) (not (eq? (first x) 'display))) attrs))
+                (filter (λ (x) (not (eq? (first x) 'display))) attrs))
          ,@bodies))
 
 (define (transform-xexpr xexpr)

ext-syntax/main.rkt

@@ -19,8 +19,8 @@
     (subprocess #f #f #f "/usr/bin/env" "python3" (path->string *python-path*) lang))
   (define out-str #f)
   (define err-str "")
-  (define out-reader (thread (lambda () (set! out-str (port->string out)))))
-  (define err-reader (thread (lambda () (set! err-str (port->string err)))))
+  (define out-reader (thread (λ () (set! out-str (port->string out)))))
+  (define err-reader (thread (λ () (set! err-str (port->string err)))))
 
   (write-string source in)
   (flush-output in)

render.rkt

@@ -4,33 +4,79 @@
          (prefix-in mathml: "ext-mathml/main.rkt")
          (prefix-in syntax: "ext-syntax/main.rkt"))
 
-(define input (port->string (current-input-port)))
-(define output-raw (parse-markdown input))
-(define output-cooked (mathml:transform-xexprs (syntax:transform-xexprs output-raw)))
-(define output-toc (toc output-cooked))
+(define metadata?
+  (listof (or/c
+            (list/c 'date integer? integer? integer?)
+            (list/c 'title string?)
+            (list/c 'summary string?)
+            (cons/c 'authors (listof string?)))))
 
-(define styles (string-append (mathml:get-styles) (syntax:get-styles)))
+(define (metadata-ref md key [default (λ () (error "no such key"))])
+  (match (assoc key md)
+    [#f (if (procedure? default) (default) default)]
+    [(cons _ rst) rst]))
 
-(define document
-  `(html
-     ([lang "en"])
-     (head
-       ()
-       (meta ([charset "utf-8"]))
-       (title () "meow meow meow")
-       (meta ([name "viewport"] [content "width=device-width, initial-scale=1"]))
-       (meta ([name "description"] [content "prototype racket markdown system uwu"]))
-       ;<link rel="shortcut icon" type="image/png" href="haskal.png"/>
-       (style ([type "text/css"]) ,styles))
-     (body
-       ()
-       (nav
+(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 metadata (read port))
+  (unless (metadata? metadata)
+    (error "post front matter is not valid metadata!"))
+  (define text (port->string port))
+  (input-document metadata text))
+
+(define *banner*
+  '(!HTML-COMMENT () " this page made with: trans rights 🏳️‍⚧️ "))
+(define *mathjax-placeholder*
+  '(div ([style "display: none"]) "__X_MATHJAX_POLYFILL_PLACEHOLDER__"))
+
+(define (markdown->html input)
+  (match-define (input-document md text) input)
+  (define output-raw (parse-markdown text))
+  (define output-cooked (mathml:transform-xexprs (syntax:transform-xexprs output-raw)))
+  (define output-toc (toc output-cooked))
+
+  (define styles (string-append (mathml:get-styles) (syntax:get-styles)))
+
+  (define document
+    `(html
+       ([lang "en"])
+       (head
          ()
-         ,output-toc)
-       (main
+         ,*banner*
+         (meta ([charset "utf-8"]))
+         (title () ,(metadata-ref+ md 'title "<untitled article>"))
+         (meta ([name "viewport"] [content "width=device-width, initial-scale=1"]))
+         ,@(match (metadata-ref+ md 'summary)
+            [#f '()]
+            [summary
+              `((meta ([name "description"] [content ,summary])))])
+         ,@(match (metadata-ref md 'authors)
+             [(or #f '()) '()]
+             [authors
+              `((meta ([name "author"] [content ,(string-join authors ", ")])))])
+         ,@(match (metadata-ref md 'date)
+             [#f '()]
+             [(list y m d)
+              `((meta ([name "DC.Date.created"] [content ,(format "~a-~a~a" y m d)])))])
+         (meta ([name "generator"] [content "meow meow meow meow"]))
+         ;<link rel="shortcut icon" type="image/png" href="haskal.png"/>
+         (style ([type "text/css"]) ,styles))
+       (body
          ()
-         ,@output-cooked)
-       (div ([style "display: none"]) "__X_MATHJAX_POLYFILL_PLACEHOLDER__"))))
+         (nav
+           ()
+           ,output-toc)
+         (main
+           ()
+           ,@output-cooked)
+         ,*mathjax-placeholder*)))
 
-(display "<!doctype html>")
-(display-xexpr document)
+  (with-output-to-string (λ () (display "<!doctype html>") (display-xexpr document))))
+
+(module+ main
+  (define doc (read-doc))
+  (displayln (markdown->html doc)))

templates/article.html.rkt

@@ -0,0 +1,34 @@
+#lang s-exp "../xtemplate.rkt"
+
+`(html
+  ([lang "en"])
+  (head
+    ()
+    ,*banner*
+    (meta ([charset "utf-8"]))
+    (title () ,(metadata-ref+ md 'title "<untitled article>"))
+    (meta ([name "viewport"] [content "width=device-width, initial-scale=1"]))
+    ,@(match (metadata-ref+ md 'summary)
+             [#f '()]
+             [summary
+               `((meta ([name "description"] [content ,summary])))])
+    ,@(match (metadata-ref md 'authors)
+             [(or #f '()) '()]
+             [authors
+               `((meta ([name "author"] [content ,(string-join authors ", ")])))])
+    ,@(match (metadata-ref md 'date)
+             [#f '()]
+             [(list y m d)
+              `((meta ([name "DC.Date.created"] [content ,(format "~a-~a~a" y m d)])))])
+    (meta ([name "generator"] [content "meow meow meow meow"]))
+    ;<link rel="shortcut icon" type="image/png" href="haskal.png"/>
+    (style ([type "text/css"]) ,styles))
+  (body
+    ()
+    (nav
+      ()
+      ,output-toc)
+    (main
+      ()
+      ,@output-cooked)
+    ,*mathjax-placeholder*))

xtemplate.rkt

@@ -0,0 +1,37 @@
+#lang racket/base
+
+(require racket/base racket/list racket/match racket/string
+         syntax/parse syntax/parse/define
+         (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/list racket/match racket/string)
+                     #%module-begin #%top))
+
+(define-for-syntax *unbound-prop* 'xtemplate:unbound)
+
+(define-for-syntax (collect-unbounds stx)
+  (define (next stx)
+    (match (syntax->list stx)
+      [#f (set)]
+      [lst (foldr set-union (set) (map collect-unbounds lst))]))
+  (match (syntax-property stx *unbound-prop*)
+    [#f (next stx)]
+    [result (set-add (next stx) result)]))
+
+(define-syntax-parse-rule (x:#%top . id:id)
+  #:with #%template-args (datum->syntax #'id '#%template-args)
+  #:with propped-id (syntax-property #'(quote id) *unbound-prop* (syntax->datum #'id))
+  (hash-ref #%template-args propped-id))
+
+(define-syntax-parse-rule (x:#%module-begin body)
+  #:with #%template-args (datum->syntax #'body '#%template-args)
+  #:with execute-fn #'(λ (#%template-args) body)
+  #:with expanded-execute-fn (local-expand #'execute-fn (syntax-local-context) '())
+  #:with (unbound-ids ...)
+    (map (λ (stx) #`(quote #,stx)) (set->list (collect-unbounds #'expanded-execute-fn)))
+  (#%module-begin
+   (provide execute required-ids)
+   (define required-ids (list unbound-ids ...))
+   (define execute expanded-execute-fn)))