From d4830cdd422258a7c91a5ed07af50f8c208a29ee Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Tue, 15 Aug 2023 23:33:17 -0500 Subject: A new start (again) --- lib/config.sld | 45 ++++++++++++++++++++++++ lib/schmaltz.sld | 17 +++++++++ lib/schmaltz.sls | 103 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/types.sld | 24 +++++++++++++ lib/types.sls | 72 ++++++++++++++++++++++++++++++++++++++ lib/util.sld | 50 +++++++++++++++++++++++++++ 6 files changed, 311 insertions(+) create mode 100644 lib/config.sld create mode 100644 lib/schmaltz.sld create mode 100644 lib/schmaltz.sls create mode 100644 lib/types.sld create mode 100644 lib/types.sls create mode 100644 lib/util.sld (limited to 'lib') diff --git a/lib/config.sld b/lib/config.sld new file mode 100644 index 0000000..bdd6ef5 --- /dev/null +++ b/lib/config.sld @@ -0,0 +1,45 @@ +;;; (boudin config) --- default values for configuration options +;; +;; To change these, make a `config.scm' in your site's root directory and change +;; these. They're all parameters so .. change em like that. + +(define-library (boudin config) + (import (scheme base) + (boudin schmaltz) + ;; not portable + (chicken pathname) + (html-parser) + ) + + (export site-url site-dest + page-path-transformers page-text-transformers + page-template index-template feed-template) + + (begin + ;; Site information + (define site-url + (make-parameter "example.com")) + (define site-dest + (make-parameter "out/")) + ;; Transformers + (define page-path-transformers + (make-parameter + (list (lambda (path) (make-pathname (site-dest) path))))) + (define page-text-transformers + (make-parameter + (list wrap-paragraphs + render-string + html->sxml))) + ;; Templates --- note that we use quote but include unquote forms here. + ;; This is to simplify the configuration and to avoid a cyclical dependency + ;; with (boudin types). + (define page-template + (make-parameter + '(html (@ (lang "en-us")) + (head (title (or (page-ref pg "title") "[untitled]"))) + (body ,@(page-sxml pg))))) + (define index-template + (make-parameter 'todo)) + (define feed-template + (make-parameter 'todo)) + )) diff --git a/lib/schmaltz.sld b/lib/schmaltz.sld new file mode 100644 index 0000000..d54d53e --- /dev/null +++ b/lib/schmaltz.sld @@ -0,0 +1,17 @@ +(define-library (boudin schmaltz) + (export render + render-string + wrap-paragraphs) + + (import (scheme base) + (scheme case-lambda) ; case-lambda + (scheme eval) ; eval + (scheme read) ; read + (scheme repl) ; interaction-environment + (scheme write) ; display + (only (html-parser) + sxml->html) + (only (srfi 152) + string-split string-trim)) + + (include "lib/schmaltz.sls")) diff --git a/lib/schmaltz.sls b/lib/schmaltz.sls new file mode 100644 index 0000000..623191f --- /dev/null +++ b/lib/schmaltz.sls @@ -0,0 +1,103 @@ +;;; (boudin schmaltz) --- transform almost-html plus scheme into html + +;;; Embedded scheme code + +(define (->string x) + (call-with-port (open-output-string) + (lambda (port) + (display x port) + (get-output-string port)))) + +(define render-string + (case-lambda + ((s) (render-string s (interaction-environment))) + ((s env) + (call-with-port (open-input-string s) + (lambda (port) + (render port env)))))) + +(define (render port env) + ;; A few rough edges: + ;; #, x will try to render x + (define (burn-char) + ;; Throw a character away. I've defined this for clarity below. + (read-char port)) + + (let loop ((ch (read-char port)) + (acc '())) + (define (proceed) (loop (read-char port) (cons ch acc))) + (cond + ((not ch) + (loop (read-char port) acc)) + ((eof-object? ch) + (list->string (reverse acc))) + ((eq? ch #\#) ; special processing to come + (case (peek-char port) + ((#\\) ; inhibit processing of the next char + (burn-char) + (loop (read-char port) (cons ch acc))) + ((#\,) ; scheme eval expansion + (burn-char) + (loop #f + (append (let ((s (->string + (eval (read port) + env)))) + (cond + ((equal? s "#") ; XXX NOT PORTABLE + '()) + ((equal? s "#!eof") ; XXX NOT PORTABLE + '(#\, #\#)) + (else (reverse (string->list s))))) + acc))) + ((#\@) ; embedded sxml + (burn-char) + (loop #f + (append (let ((h (eval `(sxml->html ,(list 'quasiquote + (read port))) + env))) + (cond + ((equal? h "#!eof") ; XXX NOT PORTABLE + '(#\@ #\#)) + (else (reverse (string->list h))))) + acc))) + (else (proceed)))) + (else (proceed))))) + +;;; Wrap paragraphs + +(define (split-paragraphs str) + (let loop ((lines (string-split str "\n")) + (par '()) + (acc '())) + (cond + ((and (null? lines) ; base case: no more lines + (null? par)) ; ... or pending paragraph + (reverse acc)) + ((null? lines) ; add the final paragraph + (loop '() '() (cons (apply string-append (reverse par)) acc))) + ((equal? (car lines) "") ; paragraph break + (loop (cdr lines) + '() + (cons (apply string-append (reverse par)) acc))) + (else ; line break + (loop (cdr lines) + (cons (string-append (car lines) "\n") par) + acc))))) + +(define (wrap-paragraphs str) + (let loop ((pars (split-paragraphs str)) + (acc '())) + (cond + ((null? pars) + (apply string-append (reverse acc))) + ((zero? (string-length (car pars))) + (loop (cdr pars) + acc)) + ((eq? #\< (string-ref (string-trim (car pars)) 0)) + (loop (cdr pars) + (cons (car pars) + acc))) + (else + (loop (cdr pars) + (cons (string-append "

" (car pars) "

\n") + acc)))))) diff --git a/lib/types.sld b/lib/types.sld new file mode 100644 index 0000000..791ff53 --- /dev/null +++ b/lib/types.sld @@ -0,0 +1,24 @@ +(define-library (boudin types) + (import (scheme base) + (scheme case-lambda) + (scheme file) + (boudin config) + (boudin util) + ;; non-portable bits + (chicken pathname) + (html-parser) + ) + + (export + ;; pages + make-page page? + page-path page-dest page-text page-sxml page-meta + set-page-dest! set-page-text! set-page-sxml! set-page-meta! + extract-metadata page-ref page-set! + page-url page-slug + read-page write-page + ;; indeces + ;; static files + ) + + (include "lib/types.sls")) diff --git a/lib/types.sls b/lib/types.sls new file mode 100644 index 0000000..2b4da5d --- /dev/null +++ b/lib/types.sls @@ -0,0 +1,72 @@ +;;; (boudin types) --- pages, indeces, and static files + +;; All paths are relative to the site directory unless otherwise noted + +(define-record-type page + (make-page path ; Input path + dest ; Output path (rel. to output directory) + text ; Input text + sxml ; Rendered sxml + meta ; Metadata (title, etc.) + ) + page? + (path page-path) + (dest page-dest set-page-dest!) + (text page-text set-page-text!) + (sxml page-sxml set-page-sxml!) + (meta page-meta set-page-meta!)) + +(define (page-ref pg key) + (assoc-ref key (page-meta pg) (identity #f))) + +(define (page-set! pg key val) + (set-page-meta! pg (cons (cons key val) + (page-meta pg)))) + +(define (extract-metadata sxml) + #f) + +(define (*urlify path) + (normalize-pathname + (make-pathname (list (site-url) + (pathname-strip-extension path)) + "index.html"))) + +(define (page-url pg) ; foo.html => http://site.com/foo/index.html + (or (page-ref pg "url") ; memoization + (let ((url (*urlify (page-path pg)))) + (page-set! pg "url" url) + url))) + +(define (*slugify url) ; I don't love how this is written.. + (let-values (((_ _ dirs) (decompose-directory url))) + (let loop ((this (car dirs)) + (rest (cdr dirs))) + (if (null? (cdr rest)) + (make-pathname (list "/" this) #f) + (loop (car rest) + (cdr rest)))))) + +(define (page-slug pg) ; http://site.com/foo/index.html => /foo/ + (or (page-ref pg "slug") ; memoization + (let ((slug (*slugify (page-url pg)))) + (page-set! pg "slug" slug) + slug))) + +(define (read-page path) + (let ((pg (make-page path #f #f #f #f))) + (set-page-dest! pg ((apply o (page-path-transformers)) path)) + (set-page-text! pg (with-input-from-file path slurp)) + (set-page-sxml! pg ((apply o (page-text-transformers)) (page-text pg))) + (set-page-meta! pg (extract-metadata (page-sxml pg))) + pg)) + +(define write-page + (case-lambda + ((pg) (call-with-output-file (page-dest pg) + (lambda (port) (write-page pg port)))) + ((pg port) + (sxml-display-as-html ((eval/q (page-template)) pg) port)))) + + + diff --git a/lib/util.sld b/lib/util.sld new file mode 100644 index 0000000..64c633e --- /dev/null +++ b/lib/util.sld @@ -0,0 +1,50 @@ +;;; (boudin util) --- utility functions + +(define-library (boudin util) + (import (scheme base) + (scheme case-lambda) + (scheme eval)) + + (export identity + o + assoc-ref + slurp + eval/q) + + (begin + (define (identity x) x) + + (define (o . procs) ; stole from chicken core + (if (null? procs) + identity + (let loop ((procs procs)) + (let ((h (car procs)) + (t (cdr procs))) + (if (null? t) + h + (lambda (x) (h ((loop t) x)))))))) + + (define assoc-ref + (case-lambda + ((key alist) + (assoc-ref alist + key + (lambda () (error "Unrecognized key." key)))) + ((key alist failure) + (cond ((assoc key alist) => cdr) + (else (failure)))))) + + (define slurp + (case-lambda + (() (slurp (current-input-port))) + ((port) + (let loop ((ch (read-char)) + (acc '())) + (if (eof-object? ch) + (list->string (reverse acc)) + (loop (read-char) (cons ch acc))))))) + + (define (eval/q form env) ; this is probably a bad idea + (eval (list 'quasiquote form) env)) + + )) -- cgit 1.4.1-21-gabe81