Commit 2423dca47e3561ef36b35e0b235bf95dd3305fb2 - when-computer

... Getty Ritter 10 years ago

6 changed file(s) with 141 addition(s) and 51 deletion(s). Collapse all Expand all

-1

generator/clean.do less more

1	1	#!/bin/sh
2	2
3		rm -rf generate ~~generate~~.c
	3	rm -rf generate *.c
4	4	exit 1

-1

generator/generate.c.do less more

2	2
3	3	redo-ifchange generate.scm
4	4	TEMP=$(mktemp -u -p $(pwd) tmpXXXXXX)
5		csc -t generate.scm -o $TEMP
	5	csc -t -static generate.scm -o $TEMP
6	6	mv $TEMP.c $3

-2

generator/generate.do less more

1	1	#!/bin/sh
2	2
3		redo-ifchange generate.c telml.c
4	3	GCC=x86_64-linux-musl-gcc
5		${GCC} -static generate.c telml.c -o $3 -I/usr/include/chicken -L/usr/lib -Wl,-R"/usr/lib" -lchicken -lm -ldl
	4	FLAGS="-static -I/usr/include/chicken -L/usr/lib -Wl,-R/usr/lib -lchicken -lm -ldl -fno-strict-aliasing -fwrapv -DHAVE_CHICKEN_CONFIG_H -DC_ENABLE_PTABLES -mtune=generic -O2 -pipe -fstack-protector-strong -D_FORTIFY_SOURCE=2 -g"
	5	SOURCES="generate.c telml.c libs.c"
	6
	7	redo-ifchange ${SOURCES}
	8	# ${GCC} generate.c telml.c -o $3 -static -I/usr/include/chicken -L/usr/lib -Wl,-R"/usr/lib" -lchicken -lm -ldl
	9	${GCC} ${SOURCES} -o $3 ${FLAGS}

+56

-15

generator/generate.scm less more

1		(require-extension scss)
2		(require-extension sxml-serializer)
3		(~~require-extension matchable~~)
	1	(declare (uses libs))
	2	(declare (uses telml))
4	3
	4	; (require-extension scss)
	5	; (require-extension sxml-serializer)
	6	; (require-extension matchable)
	7
	8	(load "libs.scm")
5	9	(load "telml.scm")
6	10
7	11	(define (pairs lst)
8		(match lst
9		[ (x . (y . rst)) (cons (list x y) (pairs rst)) ]
10		~~[ _ '() ])~~)
	12	(if (or (null? lst) (null? (cdr lst))) '()
	13	(cons (list (car lst) (cadr lst)) (cddr lst))))
11	14
12	15	;; template-ey things and style things
13	16
14	17	(define stylesheet
15		'(css
16		(body
17		(font-family "\"Arial\", \"Helvetica\", sans-serif")
18		(font-size 15pt))
	18	'((body
	19	(font-family "fira, \"Arial\", \"Helvetica\", sans-serif")
	20	(font-size 15pt)
	21	(background-color "#eeeeee")
	22	(counter-reset sidenote-counter))
19	23
20	24	((= class all)
21	25	(width 600px)

25	29
26	30	((= class menu)
27	31	(color "#0f0f0f"))
	32
	33	((= class main)
	34	(text-align justify)
	35	(line-height 150%))
28	36
29	37	((= class menu-index:before) (content "\"/ \""))
30	38	((= class menu-archive:before) (content "\"^ \""))

41	49	(padding-left 100px)
42	50	(padding-right 100px))
43	51
44		((= class sidenode)
	52	((= class sidenote)
45	53	(float right)
46	54	(clear right)
47	55	(margin-right -60%)
48		(~~width 50%)))~~)
	56	(font-size 12pt)
	57	(line-height 130%)
	58	(width 50%))
49	59
	60	((= class sidenote-number)
	61	(counter-increment sidenote-counter))
	62
	63	((&& (= class sidenote-number:after) (= class sidenote:before))
	64	(content "counter(sidenote-counter) \" \"")
	65	(position relative)
	66	(vertical-align baseline)
	67	(color "#ff0000"))
	68
	69	((= class sidenote-number:after)
	70	(content "counter(sidenote-counter) \" \"")
	71	(top -0.5rem)
	72	(left -0.1rem)
	73	(font-size: 0.9rem))
	74
	75	((= class sidenote:before)
	76	(content "counter(sidenote-counter) \". \"")
	77	(position absolute)
	78	(-webkit-transform "translateX(-100%) translateX(-0.25rem)")
	79	(-ms-transform "translateX(-100%) translateX(-0.25rem)")
	80	(transform "translateX(-100%) translateX(-0.25rem)"))))
	81
	82	;; the SXML chunk representing the navigation menu
50	83	(define menu
51	84	(let ((menu-item
52	85	(lambda (name url)

58	91	,(menu-item "tags" "/tags/")
59	92	,(menu-item "about" "/about/"))))
60	93
	94	;; The SXML chunk representing a page on the site
61	95	(define (page title content)
62	96	`(html
63	97	(head
64	98	(meta (@ (http-equiv "Content-Type")
65	99	(content "application/xhtml+xml; charset=utf-8;")))
66	100	(style (@ (type "text/css")) ,(scss->css stylesheet))
	101	(script (@ (type "text/javascript")
	102	(src "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML")))
67	103	(title ,(string-append "what happens when computer: " title)))
68	104	(div (@ (class "all"))
69	105	(div (@ (class "header"))

72	108	(div (@ (class "main")) ,content)
73	109	(div (@ (class "footer")) "© 2015 getty ritter"))))
74	110
75		(define (main title file)
76		(display (serialize-sxml (page title (translate-file file)))))
	111	;; actually load and generate the relevant files
	112	(define (main pg file)
	113	(let* ((page-source (translate-file file))
	114	(telml (cdr page-source))
	115	(meta (car page-source))
	116	(title (if meta (cadr meta) pg)))
	117	(display (serialize-sxml (page title telml)))))
77	118
78		(~~display (serialize-sxml (apply page (command-line-arguments))~~))
	119	(apply main (command-line-arguments))

-6

~~generator/telml.c.do~~ less more

1		#!/bin/bash -e
2
3		redo-ifchange telml.scm
4		TEMP=$(mktemp -u -p $(pwd) tmpXXXXXX)
5		csc -t telml.scm -o $TEMP
6		mv $TEMP.c $3

+77

-26

generator/telml.scm less more

1		(~~require-extension matchable~~)
	1	(declare (unit telml))
	2
2	3	(require-extension srfi-13)
3	4	(require-extension srfi-14)
4	5	(require-extension utils)

6	7	(define (mk-stream s)
7	8	(let ((lst (string->list s)))
8	9	(lambda (msg)
9		(match msg
10		[ 'next (match lst
11		[ (x . xs) (begin (set! lst xs) x) ]
12		[ '() #f ]) ]
13		[ 'peek (match lst
14		[ (x . xs) x ]
15		[ '() #f ]) ]
16		[ 'done (null? lst) ]))))
	10	(cond ((eq? 'next msg)
	11	(if (null? lst)
	12	#f
	13	(let ((x (car lst)))
	14	(set! lst (cdr lst))
	15	x)))
	16	((eq? 'peek msg)
	17	(if (null? lst) #f (car lst)))
	18	((eq? 'peek2 msg)
	19	(if (or (null? lst) (null? (cdr lst))) #f
	20	(cadr lst)))
	21	((eq? 'done msg) (null? lst))))))
17	22
18	23	(define (special-char? c)
19	24	(or (eq? c #\\)

47	52
48	53	(define (parse-text)
49	54	(define (go)
50		(if (special-char? (s 'peek))
51		'()
52		~~(let ((c (s 'next))) (cons c (go))~~)))
	55	(cond ((and (eq? (s 'peek) #\\) (special-char? (s 'peek2)))
	56	(begin (s 'next) (cons (s 'next) (go))))
	57	((special-char? (s 'peek)) '())
	58	(else
	59	(let ((c (s 'next))) (cons c (go))))))
53	60	(list->string (go)))
54	61
55	62	(define (skip-whitespace)

67	74	(if (eq? (s 'peek) #\})
68	75	'()
69	76	(let ((f (parse-fragment-list)))
70		(match (s 'peek)
71		[ #\\| (begin (s 'next) (cons f (parse-args))) ]
72		[ #\} (list f) ]
73		[ x (abort (cons 'unreachable x)) ]))))
	77	(cond ((eq? (s 'peek) #\\|) (begin (s 'next) (cons f (parse-args))))
	78	((eq? (s 'peek) #\}) (list f))
	79	(else (abort 'unreachable))))))
74	80
75	81	(define (parse-fragment)
76	82	(let ((c (s 'peek)))

95	101	(simple-tag 'strong)
96	102	(simple-tag 'li)
97	103	(simple-tag 'code)
98		(list-tag 'p)
99		(list-tag 'ul)
	104	(simple-tag 'h1)
	105	(simple-tag 'h2)
	106	(list-tag 'p)
	107	(list-tag 'ul)
	108	(list-tag 'ol)
	109	(simple-tag 'blockquote)
	110	(cons 'comment (lambda _ ""))
100	111	(cons 'link (lambda (url name)
101	112	`(a (@ (href ,(apply string-append url))) ,name)))
102		(cons 'sidenote (lambda (arg) `(~~div (@ (class sidenote)) ,arg)))~~)))
	113	(cons 'sidenote (lambda (arg) `(span (@ (class sidenote)) ,arg)))
	114	(cons 'ref (lambda (name)
	115	`(label (@ (for ,name) (class "sidenote-number"))))))))
	116
	117	(define (partition doc lst)
	118	(cond ((null? doc) (reverse lst))
	119	((not (car doc)) (partition (cdr doc) (cons '() lst)))
	120	(else (partition (cdr doc)
	121	(cons (append (car lst) (list (car doc)))
	122	(cdr lst))))))
	123
	124	(define (gather-para document)
	125	(define (split-string text)
	126	(let ((i (string-contains text "\n\n")))
	127	(if (not i) (list text)
	128	(cons (string-take text i)
	129	(cons #f (split-string (string-drop text (+ i 2))))))))
	130	(define (go doc)
	131	(cond ((null? doc) '())
	132	((not (string? (car doc)))
	133	(cons (car doc) (go (cdr doc))))
	134	(else
	135	(append (split-string (car doc)) (go (cdr doc))))))
	136	(partition (go document) '(())))
	137
103	138
104	139	(define (telml->sxml telml tags)
105		(let ((rec (lambda (arg) (telml->sxml arg tags))))
106		(cond ((string? telml) telml)
107		((symbol? (car telml))
108		(let ((args (map rec (cdr telml)))
109		(func (cdr (assoc (car telml) tags))))
110		(apply func args)))
	140	(define (rec arg)
	141	(cond ((string? arg) arg)
	142	((symbol? (car arg))
	143	(let ((args (map rec (cdr arg)))
	144	(func (assoc (car arg) tags)))
	145	(if func
	146	(apply (cdr func) args)
	147	(abort (format #f "Unknown tag: `~a`" (car arg))))))
111	148	(else
112		(map rec ~~telml)~~))))
	149	(map rec arg))))
	150	(let ((meta (if (and (not (null? telml))
	151	(not (null? (car telml)))
	152	(eq? (caar telml) 'meta))
	153	(caadar telml)
	154	#f))
	155	(body (if (and (not (null? telml))
	156	(not (null? (car telml)))
	157	(eq? (caar telml) 'meta))
	158	(cdr telml)
	159	telml)))
	160	(cons (if meta (call-with-input-string meta read) '())
	161	(map (lambda (x)
	162	(cons 'p (rec x)))
	163	(gather-para body)))))
113	164
114	165	(define (translate-file filename)
115	166	(telml->sxml (parse (read-all filename)) basic-tag-list))