implement intermediate doc format

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

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 <xref> 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 "<!doctype html>") (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 "<!doctype html>") (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))))

templates/article.html.rkt

@@ -26,7 +26,7 @@
                                          (~r dn #:min-width 2 #:pad-string "0"))])))])
     (meta ([name "generator"] [content "meow meow meow meow"]))
     ;<link rel="shortcut icon" type="image/png" href="haskal.png"/>
-    (style ([type "text/css"]) ,page-styles))
+    (link ([rel "stylesheet"] [type "text/css"] [href "index.css"])))
   (body
     ()
     (nav

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)