Mostly early scaffolding, no changes to the source code
Getty Ritter
8 years ago
| 1 | Van de Graaf is a static site generating tool designed for blogs | |
| 2 | and built on top of [Guile Scheme] and the generic [TeLML] markup | |
| 3 | language. | |
| 4 | ||
| 5 | ## How To Use | |
| 6 | ||
| 7 | A given page needs at least a template, and probably an input. | |
| 8 | The input is interpreted as [TeLML]. | |
| 9 | ||
| 10 | ## Man |
| 1 | % VAN-DE-GRAAF(1) User Manuals | |
| 2 | ||
| 3 | # NAME | |
| 4 | ||
| 5 | van-de-graaf - scheme-based static site generation | |
| 6 | ||
| 7 | # SYNOPSIS | |
| 8 | ||
| 9 | van-de-graaf TEMPLATE [-i file] [-o file] [-t telml definitions] | |
| 10 | [-d DECL] | |
| 11 | ||
| 12 | # DESCRIPTION | |
| 13 | ||
| 14 | *van-de-graaf* is a tool based on the GNU Guile implementation of | |
| 15 | Scheme and the TeX-inspired TeLML markup language. | |
| 16 | ||
| 17 | # EXAMPLES | |
| 18 | ||
| 19 | # OPTIONS | |
| 20 | ||
| 21 | *van-de-graaf* understands the following options: | |
| 22 | ||
| 23 | -i | |
| 24 | : Specify an input filename. If this is not specified, or if the | |
| 25 | argument `-` is given, then it will take the input file on | |
| 26 | _stdin_. | |
| 27 | ||
| 28 | -o | |
| 29 | : Specify an output filename. If this is not specified, or if the | |
| 30 | argument `-` is given, then the resulting document will appear | |
| 31 | on _stdout_. | |
| 32 | ||
| 33 | -t | |
| 34 | : Specify a file of _telml_ definitions to be used in addition to | |
| 35 | the default ones. For further detail on _telml_ extension files, | |
| 36 | see *telml-extensions(7)* | |
| 37 | ||
| 38 | -d | |
| 39 | : Specify the definition of a variable in Scheme. This can be used | |
| 40 | to convey definitions to the script. | |
| 41 | ||
| 42 | # BUGS | |
| 43 | ||
| 44 | Lots, probably. | |
| 45 | ||
| 46 | # RETURN CODES | |
| 47 | ||
| 48 | *van-de-graaf* exits with a code of 0 on success. If there was an | |
| 49 | error parsing the template file, it exits with a code of 1. If | |
| 50 | there was an error parsing the input file, it exits with a code of | |
| 51 | 2. If there was an error with the command-line arguments, it exits | |
| 52 | with a code of 3. | |
| 53 | ||
| 54 | # SEE ALSO | |
| 55 | ||
| 56 | * guile(1) | |
| 57 | * telml(7) | |
| 58 | * telml-extensions(7) | |
| 59 | * sxml(7) | |
| 60 | * <http://okmij.org/ftp/Scheme/xml.html#SXML-spec> | |
| 61 | * scss(7) | |
| 62 | ||
| 63 | # AUTHOR | |
| 64 | ||
| 65 | Getty Ritter <http://infinitenegativeutility.com> |
| 1 | (include "types.scm") | |
| 2 | (include "telml.scm") | |
| 3 | (include "libs.scm") | |
| 4 | (include "templates.scm") | |
| 5 | ||
| 6 | (use-modules (srfi srfi-1)) | |
| 7 | (use-modules (ice-9 match)) | |
| 8 | (use-modules (ice-9 ftw)) | |
| 9 | ||
| 10 | ||
| 11 | ||
| 12 | ;; Create a folder if it doesn't exist. (There does not | |
| 13 | ;; appear to be a Guile binding to mkdir -p.) | |
| 14 | (define (ensure-folder f) | |
| 15 | (if (not (file-exists? f)) | |
| 16 | (mkdir f))) | |
| 17 | ||
| 18 | ;; create an output filename from a set of path components, | |
| 19 | ;; creating the necessary folders if needed, as well. | |
| 20 | (define (outfile chunks) | |
| 21 | (define (go rest so-far) | |
| 22 | (ensure-folder so-far) | |
| 23 | (match rest | |
| 24 | (() (++ so-far "/index.html")) | |
| 25 | ((x . xs) (go xs (++ so-far "/" (as-string x)))))) | |
| 26 | (go chunks "output")) | |
| 27 | ||
| 28 | ;; create a URL from a set of path components | |
| 29 | (define (url chunks) | |
| 30 | (define (go rest so-far) | |
| 31 | (match rest | |
| 32 | (() (++ so-far "/")) | |
| 33 | ((x . xs) (go xs (++ so-far "/" (as-string x)))))) | |
| 34 | (go chunks "")) | |
| 35 | ||
| 36 | ;; Grab all the posts and their metadata from the posts folder, | |
| 37 | ;; sorted by creation time. This does unnecessary work right | |
| 38 | ;; now; parsing all of them just to get the first metadata tag | |
| 39 | ;; out of them. | |
| 40 | (define (get-all-posts) | |
| 41 | (let* ((files (cddr (file-system-tree "posts"))) | |
| 42 | (files-sorted (sort files (lambda (x y) | |
| 43 | (> (stat:mtime (cadr x)) | |
| 44 | (stat:mtime (cadr y))))))) | |
| 45 | (map (lambda (file-entry) | |
| 46 | (let* ((filename (string-append "posts/" (car file-entry))) | |
| 47 | (telml (translate-file filename)) | |
| 48 | (metadata (telml-meta telml))) | |
| 49 | (make-post filename | |
| 50 | (localtime (stat:mtime (cadr file-entry))) | |
| 51 | (meta-slug metadata) | |
| 52 | (meta-title metadata) | |
| 53 | (meta-tags metadata) | |
| 54 | (telml-content telml)))) | |
| 55 | files-sorted))) | |
| 56 | ||
| 57 | ;; This should be factored out better, but for now... eh... | |
| 58 | (define (get-all-feed-posts) | |
| 59 | (let* ((files (cddr (file-system-tree "posts"))) | |
| 60 | (files-sorted (sort files (lambda (x y) | |
| 61 | (> (stat:mtime (cadr x)) | |
| 62 | (stat:mtime (cadr y))))))) | |
| 63 | (map (lambda (file-entry) | |
| 64 | (let* ((filename (string-append "posts/" (car file-entry))) | |
| 65 | (telml (translate-feed-file filename)) | |
| 66 | (metadata (telml-meta telml))) | |
| 67 | (make-post filename | |
| 68 | (localtime (stat:mtime (cadr file-entry))) | |
| 69 | (meta-slug metadata) | |
| 70 | (meta-title metadata) | |
| 71 | (meta-tags metadata) | |
| 72 | (telml-content telml)))) | |
| 73 | files-sorted))) | |
| 74 | ||
| 75 | ;; Turn a post into an <li> element with appropriate | |
| 76 | ;; link and date. | |
| 77 | (define (post->list-elem post) | |
| 78 | (let* ((date (date->string (post-time post))) | |
| 79 | (href (post-url post)) | |
| 80 | (title (post-title post))) | |
| 81 | `(li ,(++ date ": ") (a (@ (href ,href)) ,title)))) | |
| 82 | ||
| 83 | ;; Turn a tag into an <li> element with the appropriate link | |
| 84 | (define (tag->list-elem tag) | |
| 85 | (let ((url (url (list 'tag tag)))) | |
| 86 | `(li (@ (class tag-entry)) | |
| 87 | (a (@ (href ,url)) ,tag)))) | |
| 88 | ||
| 89 | ;; Generate the archive page | |
| 90 | (define (archive) | |
| 91 | (let* ((posts (get-all-posts)) | |
| 92 | (list `(div (@ (class archive-list)) | |
| 93 | (ul | |
| 94 | ,(map post->list-elem posts))))) | |
| 95 | (with-output-to-file (outfile '(archive)) | |
| 96 | (lambda () | |
| 97 | (display (sxml->html5 (page (url '(archive)) "archive" list))))))) | |
| 98 | ||
| 99 | ;; Flatten a list | |
| 100 | (define (concat list) | |
| 101 | (apply append list)) | |
| 102 | ||
| 103 | ;; Get the list of all tags | |
| 104 | (define (get-tag-list posts) | |
| 105 | (let ((c (concat (map post-tags posts)))) | |
| 106 | (delete-duplicates (sort c string<?)))) | |
| 107 | ||
| 108 | ;; Get the list of all posts that are tagged with a given tag | |
| 109 | (define (get-posts-with-tag tag posts) | |
| 110 | (filter (lambda (post) (member tag (post-tags post))) posts)) | |
| 111 | ||
| 112 | ;; Generate all tag-related pages | |
| 113 | (define (tags) | |
| 114 | (let* ((posts (get-all-posts)) | |
| 115 | (tags (get-tag-list posts)) | |
| 116 | (tag-list `(div (@ (class archive-list)) | |
| 117 | (ul | |
| 118 | ,(map tag->list-elem tags))))) | |
| 119 | ||
| 120 | (define (mk-tag-page tag) | |
| 121 | (let* ((ps (get-posts-with-tag tag posts)) | |
| 122 | (content `(div (@ (class archive-list)) | |
| 123 | "pages tagged " | |
| 124 | (span (@ (class tag)) ,tag) | |
| 125 | ":" | |
| 126 | (ul | |
| 127 | ,(map post->list-elem ps))))) | |
| 128 | (with-output-to-file (outfile (list 'tag tag)) | |
| 129 | (lambda () | |
| 130 | (display (sxml->html5 (page (url (list 'tag tag)) | |
| 131 | tag | |
| 132 | content))))))) | |
| 133 | ||
| 134 | (with-output-to-file (outfile '(tags)) | |
| 135 | (lambda () | |
| 136 | (display (sxml->html5 (page (url '(tags)) | |
| 137 | "tags" | |
| 138 | tag-list))))) | |
| 139 | ||
| 140 | (map mk-tag-page tags))) | |
| 141 | ||
| 142 | (define (feed) | |
| 143 | (let ((posts (get-all-feed-posts))) | |
| 144 | (with-output-to-file "output/feed.xml" | |
| 145 | (lambda () | |
| 146 | (display (serialize-sxml (atom-feed posts))))))) | |
| 147 | ||
| 148 | ;; Load a telml page and turn it into an html page | |
| 149 | (define (main pg file out) | |
| 150 | (let* ((page-source (translate-file file)) | |
| 151 | (telml (telml-content page-source)) | |
| 152 | (meta (telml-meta page-source)) | |
| 153 | (date (localtime (stat:mtime (stat file)))) | |
| 154 | (ndate (date->string date)) | |
| 155 | (title (if meta (meta-title meta) pg)) | |
| 156 | (target (outfile (if out out | |
| 157 | (list ndate (meta-slug meta))))) | |
| 158 | (url (url (if out out | |
| 159 | (list ndate (meta-slug meta))))) | |
| 160 | (display (sxml->html5 (page url | |
| 161 | title | |
| 162 | (add-tags telml (meta-tags meta)))))) | |
| 163 | (format #t "printing to ~a\n" target) | |
| 164 | (with-output-to-file target | |
| 165 | (lambda () (format #t "~a\n" display))))) | |
| 166 | ||
| 167 | ;; Figure out which page is supposed to be generated | |
| 168 | (define (dispatch pg files) | |
| 169 | (match pg | |
| 170 | ("index" (main "index" (car files) '())) | |
| 171 | ("post" (map (lambda (f) (main "post" f #f)) files)) | |
| 172 | ("archive" (archive)) | |
| 173 | ("tags" (tags)) | |
| 174 | ("about" (main "about" "pages/about.telml" '(about))) | |
| 175 | ("feed" (feed)))) | |
| 176 | ||
| 177 | (let ((args (cdr (command-line)))) | |
| 178 | (cond ((= (length args) 0) | |
| 179 | (format #t "Usage: generate [page] [files]\n")) | |
| 180 | (else (dispatch (car args) (cdr args))))) |
| 1 | ;; some library stuff | |
| 2 | ||
| 3 | ;; A utility function for string-appending. | |
| 4 | (define (++ . args) (apply string-append args)) | |
| 5 | ||
| 6 | ;; Speculatively convert a symbol to a string. | |
| 7 | (define (as-string s) | |
| 8 | (if (symbol? s) (symbol->string s) s)) | |
| 9 | ||
| 10 | ;; (intercalate x (a b ... c)) produces the list (a x b x ... x c). | |
| 11 | (define (intercalate x xs) | |
| 12 | (define (go ls) | |
| 13 | (cond ((null? ls) '()) | |
| 14 | ((null? (cdr ls)) ls) | |
| 15 | (else | |
| 16 | (cons (car ls) (cons x (go (cdr ls))))))) | |
| 17 | (apply ++ (go xs))) | |
| 18 | ||
| 19 | ;; | |
| 20 | (define (scss->css scss) | |
| 21 | (define (mk-selector selector) | |
| 22 | (cond ((symbol? selector) | |
| 23 | (symbol->string selector)) | |
| 24 | ((and (list? selector) | |
| 25 | (eq? (car selector) '=) | |
| 26 | (eq? (cadr selector) 'class)) | |
| 27 | (++ "." (symbol->string (caddr selector)))) | |
| 28 | ((and (list? selector) | |
| 29 | (eq? (car selector) '=) | |
| 30 | (eq? (cadr selector) 'id)) | |
| 31 | (++ "#" (symbol->string (caddr selector)))) | |
| 32 | ((and (list? selector) | |
| 33 | (eq? (car selector) '//)) | |
| 34 | (intercalate " " (map mk-selector (cdr selector)))) | |
| 35 | ((and (list? selector) | |
| 36 | (eq? (car selector) '&&)) | |
| 37 | (intercalate "," (map mk-selector (cdr selector)))) | |
| 38 | (else "..."))) | |
| 39 | (define (mk-line line) | |
| 40 | (++ " " (as-string (car line)) ": " (as-string (cadr line)) ";\n")) | |
| 41 | (define (mk-clause clause) | |
| 42 | (++ | |
| 43 | (mk-selector (car clause)) | |
| 44 | " {\n" | |
| 45 | (apply ++ (map mk-line (cdr clause))) | |
| 46 | "}\n")) | |
| 47 | (apply ++ (map mk-clause scss))) | |
| 48 | ||
| 49 | (define (cadr? sexp) | |
| 50 | (if (or (null? sexp) | |
| 51 | (null? (cdr sexp)) | |
| 52 | (not (list? (cadr sexp)))) | |
| 53 | #f (cadr sexp))) | |
| 54 | ||
| 55 | (define (serialize-sxml sxml) | |
| 56 | (define (mk-prop prop) | |
| 57 | (let ((key (as-string (car prop))) (val (as-string (cadr prop)))) | |
| 58 | (++ " " key "=" | |
| 59 | (if (string? val) (++ "\"" val "\"") (as-string val))))) | |
| 60 | (cond ((null? sxml) "") | |
| 61 | ((string? sxml) sxml) | |
| 62 | ((symbol? sxml) (symbol->string sxml)) | |
| 63 | ((not (symbol? (car sxml))) | |
| 64 | (apply string-append (map serialize-sxml sxml))) | |
| 65 | (else | |
| 66 | (let ((tag (symbol->string (car sxml))) | |
| 67 | (props (if (and (cadr? sxml) (eq? (caadr sxml) '@)) | |
| 68 | (cdadr sxml) '())) | |
| 69 | (vals (if (and (cadr? sxml) (eq? (caadr sxml) '@)) | |
| 70 | (cddr sxml) (cdr sxml)))) | |
| 71 | (if (null? vals) | |
| 72 | (++ "<" | |
| 73 | tag | |
| 74 | (apply ++ (map mk-prop props)) | |
| 75 | " />") | |
| 76 | (++ "<" | |
| 77 | tag | |
| 78 | (apply ++ (map mk-prop props)) | |
| 79 | ">" | |
| 80 | (apply ++ (map serialize-sxml vals)) | |
| 81 | "</" | |
| 82 | tag | |
| 83 | ">")))))) | |
| 84 | ||
| 85 | (define (sxml->html5 sxml) | |
| 86 | (++ "<!DOCTYPE html>" (serialize-sxml sxml))) |
| 1 | (use-modules (ice-9 match)) | |
| 2 | (use-modules (ice-9 rdelim)) | |
| 3 | (use-modules (ice-9 regex)) | |
| 4 | (use-modules (srfi srfi-9)) | |
| 5 | ||
| 6 | (define-record-type <telml-doc> | |
| 7 | (make-telml-doc meta content) | |
| 8 | telml-doc? | |
| 9 | (meta telml-meta) | |
| 10 | (content telml-content)) | |
| 11 | ||
| 12 | (define-record-type <meta> | |
| 13 | (make-meta slug title tags) | |
| 14 | meta? | |
| 15 | (slug meta-slug) | |
| 16 | (title meta-title) | |
| 17 | (tags meta-tags)) | |
| 18 | ||
| 19 | (define (mk-stream s) | |
| 20 | (let ((lst (string->list s))) | |
| 21 | (lambda (msg) | |
| 22 | (cond ((eq? 'next msg) | |
| 23 | (if (null? lst) | |
| 24 | #f | |
| 25 | (let ((x (car lst))) | |
| 26 | (set! lst (cdr lst)) | |
| 27 | x))) | |
| 28 | ((eq? 'peek msg) | |
| 29 | (if (null? lst) #f (car lst))) | |
| 30 | ((eq? 'peek2 msg) | |
| 31 | (if (or (null? lst) (null? (cdr lst))) #f | |
| 32 | (cadr lst))) | |
| 33 | ((eq? 'done msg) (null? lst)))))) | |
| 34 | ||
| 35 | (define (special-char? c) | |
| 36 | (or (eq? c #\\) | |
| 37 | (eq? c #\{) | |
| 38 | (eq? c #\}) | |
| 39 | (eq? c #\|) | |
| 40 | (not c))) | |
| 41 | ||
| 42 | (define (stream->list s) | |
| 43 | (if (s 'peek) (cons (s 'next) (stream->list s)) '())) | |
| 44 | ||
| 45 | (define (ident-char? c) | |
| 46 | (let ((i (char->integer c))) | |
| 47 | (or (= i 45) (= i 95) | |
| 48 | (and (>= i 64) (<= i 90)) | |
| 49 | (and (>= i 97) (<= i 122))))) | |
| 50 | ||
| 51 | (define (whitespace? c) | |
| 52 | (let ((i (char->integer c))) | |
| 53 | (or (= i 9) (= i 10) (= i 13) (= i 32)))) | |
| 54 | ||
| 55 | (define (parse str) | |
| 56 | (let ((s (mk-stream str))) | |
| 57 | ||
| 58 | (define (match-char c) | |
| 59 | (if (eq? (s 'next) c) #t (raise c))) | |
| 60 | ||
| 61 | (define (parse-tag) | |
| 62 | (let* ((_ (match-char #\\)) | |
| 63 | (name (parse-tag-name)) | |
| 64 | (_ (skip-whitespace)) | |
| 65 | (_ (match-char #\{)) | |
| 66 | (args (parse-args)) | |
| 67 | (_ (match-char #\}))) | |
| 68 | `(,(string->symbol name) ,@args))) | |
| 69 | ||
| 70 | (define (parse-text) | |
| 71 | (define (go) | |
| 72 | (cond ((and (eq? (s 'peek) #\\) (special-char? (s 'peek2))) | |
| 73 | (begin (s 'next) (cons (s 'next) (go)))) | |
| 74 | ((special-char? (s 'peek)) '()) | |
| 75 | (else | |
| 76 | (let ((c (s 'next))) (cons c (go)))))) | |
| 77 | (list->string (go))) | |
| 78 | ||
| 79 | (define (skip-whitespace) | |
| 80 | (if (whitespace? (s 'peek)) | |
| 81 | (begin (s 'next) (skip-whitespace)))) | |
| 82 | ||
| 83 | (define (parse-tag-name) | |
| 84 | (define (go) | |
| 85 | (if (ident-char? (s 'peek)) | |
| 86 | (cons (s 'next) (go)) | |
| 87 | '())) | |
| 88 | (list->string (go))) | |
| 89 | ||
| 90 | (define (parse-args) | |
| 91 | (if (eq? (s 'peek) #\}) | |
| 92 | '() | |
| 93 | (let ((f (parse-fragment-list))) | |
| 94 | (cond ((eq? (s 'peek) #\|) (begin (s 'next) (cons f (parse-args)))) | |
| 95 | ((eq? (s 'peek) #\}) (list f)) | |
| 96 | (else (raise 'unreachable)))))) | |
| 97 | ||
| 98 | (define (parse-fragment) | |
| 99 | (let ((c (s 'peek))) | |
| 100 | (cond ((not c) '()) | |
| 101 | ((eq? c #\\) (parse-tag)) | |
| 102 | (else (parse-text))))) | |
| 103 | ||
| 104 | (define (parse-fragment-list) | |
| 105 | (cond ((or (not (s 'peek)) | |
| 106 | (eq? (s 'peek) #\}) | |
| 107 | (eq? (s 'peek) #\|)) '()) | |
| 108 | (else (let* ((f (parse-fragment)) | |
| 109 | (fs (parse-fragment-list))) | |
| 110 | (cons f fs))))) | |
| 111 | ||
| 112 | (parse-fragment-list))) | |
| 113 | ||
| 114 | (define basic-tag-list | |
| 115 | (let ((simple-tag (lambda (n) (cons n (lambda (arg) (list n arg))))) | |
| 116 | (list-tag (lambda (n) (cons n (lambda args (cons n args)))))) | |
| 117 | (list (simple-tag 'em) | |
| 118 | (simple-tag 'strong) | |
| 119 | (simple-tag 'li) | |
| 120 | (simple-tag 'h1) | |
| 121 | (simple-tag 'h2) | |
| 122 | (list-tag 'sub) | |
| 123 | (cons 'p (lambda (n) `(div (@ (class para)) ,@n))) | |
| 124 | (list-tag 'ul) | |
| 125 | (list-tag 'ol) | |
| 126 | (simple-tag 'blockquote) | |
| 127 | (cons 'ttcom (lambda (n) `(span (@ (class comment)) ,n))) | |
| 128 | (cons 'ttkw (lambda (n) `(span (@ (class keyword)) ,n))) | |
| 129 | (cons 'ttcn (lambda (n) `(span (@ (class constr)) ,n))) | |
| 130 | (cons 'ttstr (lambda (n) `(span (@ (class string)) ,n))) | |
| 131 | (cons 'tt (lambda (n) (list 'code n))) | |
| 132 | (cons 'br (lambda _ `(br))) | |
| 133 | (cons 'code (lambda (n) `(pre (code ,n)))) | |
| 134 | (cons 'comment (lambda _ "")) | |
| 135 | (cons 'link (lambda (url name) | |
| 136 | `(a (@ (href ,(apply string-append url))) ,name))) | |
| 137 | (cons 'img (lambda (src) | |
| 138 | `(img (@ (src ,(apply string-append src)))))) | |
| 139 | (cons 'center (lambda (arg) | |
| 140 | `(div (@ (align "center")) ,arg)))))) | |
| 141 | ||
| 142 | (define standard-tag-list | |
| 143 | (append basic-tag-list | |
| 144 | (list (cons 'wd (lambda (wd mn) | |
| 145 | `(span (@ (class "word")) | |
| 146 | ,wd | |
| 147 | (span (@ (class "meaning")) ,mn)))) | |
| 148 | (cons 'sidenote (lambda (arg) | |
| 149 | `(span (@ (class sidenote)) ,arg))) | |
| 150 | (cons 'ref (lambda (name) | |
| 151 | `(label (@ (for ,(car name)) (class "sidenote-number")) "")))))) | |
| 152 | ||
| 153 | (define feed-tag-list | |
| 154 | (append basic-tag-list | |
| 155 | (list (cons 'wd (lambda (wd _) wd)) | |
| 156 | (cons 'sidenote (lambda _ "")) | |
| 157 | (cons 'ref (lambda _ ""))))) | |
| 158 | ||
| 159 | (define (partition doc lst) | |
| 160 | (cond ((null? doc) (reverse lst)) | |
| 161 | ((not (car doc)) (partition (cdr doc) (cons '() lst))) | |
| 162 | (else (partition (cdr doc) | |
| 163 | (cons (append (car lst) (list (car doc))) | |
| 164 | (cdr lst)))))) | |
| 165 | ||
| 166 | (define (string-take str i) | |
| 167 | (substring str 0 i)) | |
| 168 | ||
| 169 | (define (string-drop str i) | |
| 170 | (let ((l (string-length str))) | |
| 171 | (substring str i l))) | |
| 172 | ||
| 173 | (define (gather-para document) | |
| 174 | (define (split-string text) | |
| 175 | (let ((m (string-match "\n\n" text))) | |
| 176 | (if (not m) (list text) | |
| 177 | (let ((i (match:start m))) | |
| 178 | (cons (string-take text i) | |
| 179 | (cons #f (split-string (string-drop text (+ i 2))))))))) | |
| 180 | (define (go doc) | |
| 181 | (cond ((null? doc) '()) | |
| 182 | ((not (string? (car doc))) | |
| 183 | (cons (car doc) (go (cdr doc)))) | |
| 184 | (else | |
| 185 | (append (split-string (car doc)) (go (cdr doc)))))) | |
| 186 | (partition (go document) '(()))) | |
| 187 | ||
| 188 | (define (string->sexp str) | |
| 189 | (call-with-input-string str read)) | |
| 190 | ||
| 191 | (define (escape-chars str) | |
| 192 | (define (go c rest) | |
| 193 | (cond | |
| 194 | ((eq? c #\<) | |
| 195 | (cons #\; (cons #\t (cons #\l (cons #\& rest))))) | |
| 196 | ((eq? c #\>) | |
| 197 | (cons #\; (cons #\t (cons #\g (cons #\& rest))))) | |
| 198 | ((eq? c #\&) | |
| 199 | (cons #\; (cons #\p (cons #\m (cons #\a (cons #\& rest)))))) | |
| 200 | (else (cons c rest)))) | |
| 201 | (reverse-list->string (string-fold go '() str))) | |
| 202 | ||
| 203 | (define (telml->sxml telml tags) | |
| 204 | (define (rec arg) | |
| 205 | (cond ((string? arg) (escape-chars arg)) | |
| 206 | ((symbol? (car arg)) | |
| 207 | (let ((args (map rec (cdr arg))) | |
| 208 | (func (assoc (car arg) tags))) | |
| 209 | (if func | |
| 210 | (apply (cdr func) args) | |
| 211 | (raise "Unknown tag")))) | |
| 212 | (else | |
| 213 | (map rec arg)))) | |
| 214 | (let ((meta (match telml | |
| 215 | ((('meta (xs)) . _) xs) | |
| 216 | (_ #f))) | |
| 217 | (body (match telml | |
| 218 | ((('meta _) . xs) xs) | |
| 219 | (xs xs)))) | |
| 220 | (make-telml-doc | |
| 221 | (if meta (apply make-meta (string->sexp meta)) '()) | |
| 222 | (map (lambda (x) | |
| 223 | `(div (@ (class para)) ,(rec x))) | |
| 224 | (gather-para body))))) | |
| 225 | ||
| 226 | (define (translate-file filename) | |
| 227 | (let ((body (with-input-from-file filename read-string))) | |
| 228 | (telml->sxml (parse body) standard-tag-list))) | |
| 229 | ||
| 230 | (define (translate-feed-file filename) | |
| 231 | (let ((body (with-input-from-file filename read-string))) | |
| 232 | (telml->sxml (parse body) feed-tag-list))) |
| 1 | ;; template-ey things and style things | |
| 2 | ||
| 3 | ;; The date format we're using is {year:04}-{month:02}-{day:02}. | |
| 4 | (define (date->string date) | |
| 5 | (strftime "%Y-%m-%d" date)) | |
| 6 | ||
| 7 | (define (date->tz date) | |
| 8 | (strftime "%Y-%m-%dT%TZ" date)) | |
| 9 | ||
| 10 | (define (post-url post) | |
| 11 | (let ((date (date->string (post-time post))) | |
| 12 | (slug (post-slug post))) | |
| 13 | (format #f "/~a/~a/" date slug))) | |
| 14 | ||
| 15 | (define (atom-element post) | |
| 16 | (let ((url (++ "http://what.happens.when.computer" (post-url post)))) | |
| 17 | `(entry | |
| 18 | (title ,(post-title post)) | |
| 19 | (link (@ (href ,url))) | |
| 20 | (id ,url) | |
| 21 | (updated ,(date->tz (post-time post))) | |
| 22 | (author | |
| 23 | (name "Getty Ritter") | |
| 24 | (email "gettyritter@gmail.com")) | |
| 25 | (content | |
| 26 | (@ (type "xhtml")) | |
| 27 | (div (@ (xmlns "http://www.w3.org/1999/xhtml")) | |
| 28 | ,(post-content post)))))) | |
| 29 | ||
| 30 | (define (atom-feed posts) | |
| 31 | (let ((updated (date->tz (post-time (car posts))))) | |
| 32 | `(feed (@ (xmlns "http://www.w3.org/2005/Atom")) | |
| 33 | (title "what happens when computer") | |
| 34 | (link (@ (href "http://what.happens.when.computer/feed.xml") | |
| 35 | (rel "self"))) | |
| 36 | (link (@ (href "http://what.happens.when.computer/"))) | |
| 37 | (updated ,updated) | |
| 38 | (id "http://what.happens.when.computer/") | |
| 39 | ,(map (lambda (post) (atom-element post)) posts)))) | |
| 40 | ||
| 41 | ;; the scss stylesheet | |
| 42 | (define stylesheet | |
| 43 | '((body | |
| 44 | (font-family "Palatino, \"Palatino Linotype\", \"Palatino LT STD\", \"Book Antiqua\", Georgia, serif") | |
| 45 | (font-size 15pt) | |
| 46 | (background-color "#eeeeee") | |
| 47 | (counter-reset sidenote-counter)) | |
| 48 | ||
| 49 | (a:link | |
| 50 | (color "#336699")) | |
| 51 | ||
| 52 | (a:visited | |
| 53 | (color "#104070")) | |
| 54 | ||
| 55 | ((= class all) | |
| 56 | (width 800px) | |
| 57 | (margin-left auto) | |
| 58 | (margin-right auto) | |
| 59 | (text-align center)) | |
| 60 | ||
| 61 | ((= class menu) | |
| 62 | (color "#0f0f0f")) | |
| 63 | ||
| 64 | ((= class main) | |
| 65 | (padding-right 25%) | |
| 66 | (text-align justify) | |
| 67 | (line-height 150%)) | |
| 68 | ||
| 69 | ((= class menu-index:before) | |
| 70 | (font-family "fira, \"Arial\", \"Helvetica\", sans-serif") | |
| 71 | (content "\"/ \"")) | |
| 72 | ((= class menu-archive:before) | |
| 73 | (font-family "fira, \"Arial\", \"Helvetica\", sans-serif") | |
| 74 | (content "\"^ \"")) | |
| 75 | ((= class menu-tags:before) | |
| 76 | (font-family "fira, \"Arial\", \"Helvetica\", sans-serif") | |
| 77 | (content "\"# \"")) | |
| 78 | ((= class menu-about:before) | |
| 79 | (font-family "fira, \"Arial\", \"Helvetica\", sans-serif") | |
| 80 | (content "\"@ \"")) | |
| 81 | ||
| 82 | ((// (= class navlist) li) | |
| 83 | (display inline) | |
| 84 | (list-style-type none) | |
| 85 | (padding-left 10px) | |
| 86 | (padding-right 20px)) | |
| 87 | ||
| 88 | ((// (= class navlist) ul) | |
| 89 | (padding-left 100px) | |
| 90 | (padding-right 100px)) | |
| 91 | ||
| 92 | ((// (= class archive-list) ul) | |
| 93 | (padding-left 100px) | |
| 94 | (padding-right 100px)) | |
| 95 | ||
| 96 | ((// (= class archive-list) li) | |
| 97 | (list-style-type none)) | |
| 98 | ||
| 99 | ((= class tag-entry:before) | |
| 100 | (content "\"#\"")) | |
| 101 | ||
| 102 | ((// (= class tags) ul) | |
| 103 | (display inline)) | |
| 104 | ||
| 105 | ((= class para) | |
| 106 | (padding-top 20px)) | |
| 107 | ||
| 108 | ((= class tag:before) | |
| 109 | (content "\"#\"")) | |
| 110 | ||
| 111 | ((= class tag) | |
| 112 | (font-style italic)) | |
| 113 | ||
| 114 | ((= class word) | |
| 115 | (position relative) | |
| 116 | (padding "2px 4px 2px 4px") | |
| 117 | (border-radius "5px") | |
| 118 | (color "#993366")) | |
| 119 | ||
| 120 | ((// (= class word) span) | |
| 121 | (display none)) | |
| 122 | ||
| 123 | ((= class word:hover) | |
| 124 | (background-color "white")) | |
| 125 | ||
| 126 | ((// (= class word:hover) span) | |
| 127 | (display block) | |
| 128 | (background-color "#cccccc") | |
| 129 | (border-radius "5px") | |
| 130 | (color "black") | |
| 131 | (position absolute) | |
| 132 | (padding "5px") | |
| 133 | (top "1.3em") | |
| 134 | (left "0px") | |
| 135 | (max-width "400px") | |
| 136 | (white-space "nowrap") | |
| 137 | (z-index "50")) | |
| 138 | ||
| 139 | ((= class sidenote) | |
| 140 | (float right) | |
| 141 | (clear right) | |
| 142 | (margin-right -60%) | |
| 143 | (font-size 12pt) | |
| 144 | (line-height 130%) | |
| 145 | (width 50%)) | |
| 146 | ||
| 147 | ((= class sidenote-number) | |
| 148 | (counter-increment sidenote-counter)) | |
| 149 | ||
| 150 | ((&& (= class sidenote-number:after) (= class sidenote:before)) | |
| 151 | (content "counter(sidenote-counter) \" \"") | |
| 152 | (position relative) | |
| 153 | (color "#3366bb")) | |
| 154 | ||
| 155 | ((= class sidenote-number:after) | |
| 156 | (content "counter(sidenote-counter) \" \"") | |
| 157 | (top -0.5rem) | |
| 158 | (left -0.1rem) | |
| 159 | (vertical-align super) | |
| 160 | (font-size 70%) | |
| 161 | (color "#3366bb") | |
| 162 | (font-size: 0.9rem)) | |
| 163 | ||
| 164 | ((= class sidenote:before) | |
| 165 | (content "counter(sidenote-counter) \". \"") | |
| 166 | (position absolute) | |
| 167 | (-webkit-transform "translateX(-100%) translateX(-0.25rem)") | |
| 168 | (-ms-transform "translateX(-100%) translateX(-0.25rem)") | |
| 169 | (transform "translateX(-100%) translateX(-0.25rem)")) | |
| 170 | ||
| 171 | ((= class constr) (color "#993366")) | |
| 172 | ((= class string) (color "#339966")) | |
| 173 | ((= class comment) (color "#666666")) | |
| 174 | ((= class keyword) (color "#336699")))) | |
| 175 | ||
| 176 | ;; the SXML chunk representing the navigation menu | |
| 177 | (define menu | |
| 178 | (let ((menu-item | |
| 179 | (lambda (name url) | |
| 180 | `(li (@ (class ,(string-append "menu-" name))) | |
| 181 | (a (@ (href ,url)) ,name))))) | |
| 182 | `(ul (@ (class navlist)) | |
| 183 | ,(menu-item "index" "/") | |
| 184 | ,(menu-item "archive" "/archive/") | |
| 185 | ,(menu-item "tags" "/tags/") | |
| 186 | ,(menu-item "about" "/about/")))) | |
| 187 | ||
| 188 | ;; The SXML chunk representing a page on the site | |
| 189 | (define (page url title content) | |
| 190 | `(html | |
| 191 | (head | |
| 192 | (meta (@ (http-equiv "Content-Type") | |
| 193 | (content "application/xhtml+xml; charset=utf-8;"))) | |
| 194 | (meta (@ (property "og:title") | |
| 195 | (content ,(++ "what happens when computer: " title)))) | |
| 196 | (meta (@ (property "og:url") | |
| 197 | (content ,(++ "http://what.happens.when.computer" url)))) | |
| 198 | (meta (@ (property "og:image") | |
| 199 | (content "http://what.happens.when.computer/static/when-computer.png"))) | |
| 200 | (meta (@ (property "og:type") | |
| 201 | (content "website"))) | |
| 202 | (link (@ (href "/feed.xml") | |
| 203 | (type "application/atom+xml") | |
| 204 | (rel "alternate") | |
| 205 | (title "what happens when computer atom feed"))) | |
| 206 | (link (@ (rel "icon") | |
| 207 | (type "image/png") | |
| 208 | (href "http://what.happens.when.computer/static/when-computer-icon.png"))) | |
| 209 | (style (@ (type "text/css")) ,(scss->css stylesheet)) | |
| 210 | (script (@ (type "text/javascript") | |
| 211 | (src "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML")) "") | |
| 212 | (title ,(string-append "what happens when computer: " title))) | |
| 213 | (div (@ (class "all")) | |
| 214 | (div (@ (class "header")) | |
| 215 | (h1 "what happens when computer")) | |
| 216 | (div (@ (class "nav")) ,menu) | |
| 217 | (div (@ (class "main")) ,content) | |
| 218 | (div (@ (class "footer")) "© 2016 getty ritter")))) | |
| 219 | ||
| 220 | ;; if a page has tags, add those tags to the end of the page | |
| 221 | (define (add-tags chunk tags) | |
| 222 | (define (tag->link tag) | |
| 223 | `(a (@ (href ,(format #f "/tag/~a/" tag)) | |
| 224 | (class tag)) ,tag)) | |
| 225 | (if (null? tags) | |
| 226 | chunk | |
| 227 | (append chunk | |
| 228 | `((div (@ (class "tags")) | |
| 229 | (ul ,(map tag->link tags))))))) |