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)
---
.dir-locals.el | 4 +
.gitignore | 10 +-
.repl | 4 +
Makefile | 15 --
boudin.egg | 49 ++++--
boudin.scm | 521 +------------------------------------------------------
boudin.sld | 7 +
lib/config.sld | 45 +++++
lib/schmaltz.sld | 17 ++
lib/schmaltz.sls | 103 +++++++++++
lib/types.sld | 24 +++
lib/types.sls | 72 ++++++++
lib/util.sld | 50 ++++++
test/test.html | 19 --
14 files changed, 379 insertions(+), 561 deletions(-)
create mode 100644 .dir-locals.el
create mode 100644 .repl
delete mode 100644 Makefile
mode change 100755 => 100644 boudin.scm
create mode 100644 boudin.sld
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
delete mode 100644 test/test.html
diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..9c78ce8
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,4 @@
+;;; Directory Local Variables -*- no-byte-compile: t -*-
+;;; For more information see (info "(emacs) Directory Variables")
+
+((scheme-mode . ((geiser-scheme-implementation . chicken))))
diff --git a/.gitignore b/.gitignore
index 8e87b45..0b68fed 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,9 @@
boudin
-*.sh
-out
\ No newline at end of file
+*.inline
+*.link
+*.so
+*.o
+*.import.scm
+*.types
+*.build.sh
+*.install.sh
\ No newline at end of file
diff --git a/.repl b/.repl
new file mode 100644
index 0000000..229237b
--- /dev/null
+++ b/.repl
@@ -0,0 +1,4 @@
+;; -*- scheme -*-
+(import (beaker system))
+
+(print "> (load-system \"boudin.egg\")")
diff --git a/Makefile b/Makefile
deleted file mode 100644
index 48999db..0000000
--- a/Makefile
+++ /dev/null
@@ -1,15 +0,0 @@
-# boudin : a small static site generator
-
-DESTDIR =
-PREFIX = $(DESTDIR)/usr
-
-boudin: boudin.scm
- chicken-install -n
-
-.PHONY: install
-install:
- chicken-install
-
-.PHONY: clean
-clean:
- rm -f *.build.sh *.install.sh
diff --git a/boudin.egg b/boudin.egg
index cc163ed..e9ca2dc 100644
--- a/boudin.egg
+++ b/boudin.egg
@@ -1,17 +1,42 @@
-;; boudin -*- scheme
+;;; boudin -*- scheme -*-
-((synopsis "A small static site generator.")
+((synopsis "A small tasty ssg.")
(author "Case Duckworth")
- (version "12044")
+ (version "0.0.0")
(license "God Willing License")
- (category fluff)
- (dependencies chicanery
- atom
+
+ (dependencies chicanery r7rs utf8
html-parser
- scss
- srfi-37
- srfi-152
- sxml-serializer
- sxpath)
+ srfi-152)
+
+ (component-options
+ (csc-options "-X" "r7rs" "-R" "r7rs"
+ "-X" "utf8" "-R" "utf8"
+ "-no-warnings"))
+
(components
- (program boudin)))
+ (program boudin
+ (component-dependencies boudin-lib))
+
+ (extension boudin-lib
+ (source boudin.sld)
+ (modules boudin)
+ (install-name boudin)
+ (component-dependencies boudin.schmaltz))
+
+ (extension boudin.config
+ (source lib/config.sld)
+ (component-dependencies boudin.schmaltz))
+
+ (extension boudin.schmaltz
+ (source lib/schmaltz.sld)
+ (source-dependencies lib/schmaltz.sls))
+
+ (extension boudin.types
+ (source lib/types.sld)
+ (source-dependencies lib/types.sls)
+ (component-dependencies boudin.config
+ boudin.util))
+
+ (extension boudin.util
+ (source lib/util.sld))))
diff --git a/boudin.scm b/boudin.scm
old mode 100755
new mode 100644
index 28727ff..7bd741d
--- a/boudin.scm
+++ b/boudin.scm
@@ -1,519 +1,14 @@
-#!/bin/sh
-#| -*- scheme -*-
-exec csi -R r7rs -s "$0" "$@"
-boudin --- a little static site generator
-|#
+;;; (boudin) --- A small tasty ssg
-(import (chicken file)
- (chicken file posix)
- (chicken irregex)
- (chicken pathname)
- (chicken port)
- (chicken process-context)
- (chicken random)
- (chicken string)
- (chicken time posix)
- (chicanery)
- (atom)
- (html-parser)
- (scss)
- (srfi 37)
- (srfi 152)
- (sxml-serializer)
- (sxpath))
+(import (boudin))
-;;; Utilities
+(define foo (render-string "#,hello from Boudin!"
+ (interaction-environment)))
-(define el sxml->html)
-
-;;; Transformations
-;; A static site generator can be thought of largely as two sets of
-;; transformations: one transforming given input content to output content, and
-;; another transforming source paths to destination paths. Since both, for my
-;; purposes, are strings, I have a generic function that can perform both
-;; transformations.
-
-(define (transform str . procs) #| string (string ->string) ... -> string
- Apply PROCS to STR, left-to-right, and return the result.
- Each PROC will be called with its predecessor's output, and should take a
- string as input and return a string. |#
- (if (null? procs)
- str
- (apply transform ((car procs) str) (cdr procs))))
-
-;;; Path transformations
-
-(define (indexify path) #| path -> path
- Replace the PATH's extension with "/index.html".
- |#
- (make-pathname (pathname-strip-extension path)
- "index"
- "html"))
-
-(define (slugify path)
- (transform path
- normalize-pathname
- ;; XXX: this should be much more robust
- (lambda (p) (pathname-replace-directory p "/"))
- pathname-strip-extension
- (lambda (p) (string-append p "/"))))
-
-(define (transform-path path outdir) #| path => path
- Transform PATH according to boudin's needs. |#
- (transform path
- normalize-pathname
- (lambda (p) (pathname-replace-directory p outdir))
- indexify))
-
-;;; Content transformations
-
-(define (split-paragraphs str) #| string -> (list string ...)
- Split STR into paragraphs.
- A paragraph is a contiguous series of text lines separated from other
- paragraphs by at least 2 newline \n characters. This procedure collapses
- inter-paragraph space. |#
- (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) #| string -> string
- Wrap naked paragraphs of STR in tags.
- A 'naked' paragraph is one that doesn't begin with '<' (after optional
- beginning whitespace). |#
- (let loop ((pars (map string-trim (split-paragraphs str)))
- (acc '()))
- (cond
- ((null? pars)
- (apply string-append (reverse acc)))
- ((zero? (string-length (car pars)))
- (loop (cdr pars)
- acc))
- ((eq? #\< (string-ref (car pars) 0))
- (loop (cdr pars)
- (cons (car pars)
- acc)))
- (else
- (loop (cdr pars)
- (cons (string-append "
" (car pars) "
\n")
- acc))))))
-
-(define (preprocess-text str) #| string -> string
- Preprocess STR before passing it to `expand-string'.
- For example, replace all '#' with '##' unless followed by a '{' or '('.
- |#
- (set! str (irregex-replace/all
- '(or (: #\# #\# (look-ahead (or #\{ #\()))
- (: #\# (look-ahead (~ #\{ #\()))
- (: #\# eos))
- str
- "##"))
- #; (set! str (irregex-replace/all ; XXX: missing end paren
- '(: #\@ #\()
- str
- "#(sxml->html `("))
- ;; Return transformed string
- str)
-
-(define (expand-string str) #| string -> string
- Expand STR by passing it in a port to CHICKEN's #<# string interpolation.
- Yes, this is as cursed as it sounds.
-
- To make it slightly less so, all # are duplicated to escape them, except for
- those before ( and {. To escape /those/, double them. |#
- (let* ((delim (let loop ((attempt (number->string (pseudo-random-real))))
- (if (irregex-search attempt str)
- (loop (number->string (pseudo-random-real)))
- attempt)))
- (template (make-concatenated-port
- (open-input-string (string-append "#<#" delim "\n"))
- (open-input-string (preprocess-text str))
- (open-input-string (string-append "\n" delim "\n"))))
- (expanded (with-output-to-string
- (lambda ()
- (display (eval (read template)
- (interaction-environment)))))))
- (irregex-replace/all '(: "#"
- (* whitespace))
- expanded
- "")))
-
-(define (transform-content content) #| string -> string
- Transform CONTENT according to boudin's needs.
- This is the raw html, and will still need to be processed to extract metadata
- and to be further wrapped in a template. |#
- (transform content
- expand-string
- wrap-paragraphs))
-
-;;; Pages
-;; A is a record type that wraps the two transformations outlined above.
-;; It also includes the extracted metadata from the page for processing.
-
-(define-record-type
- (make-page slug meta source dest source-path dest-path)
- page?
- (slug page-slug (setter page-slug))
- (meta page-meta (setter page-meta))
- (source page-source)
- (dest page-dest (setter page-dest))
- (source-path page-source-path)
- (dest-path page-dest-path (setter page-dest-path)))
-
-(define (page-url page)
- (normalize-pathname
- (make-pathname (list (site-base-url)
- (page-slug page))
- #f)))
-
-(define (%read-port port) #| port -> string
- Read PORT until it hits eof and return the results as a string.
- |#
- (let ((chunk-size 512))
- (let loop ((next (read-string chunk-size port))
- (blank? #f)
- (acc '()))
- (cond
- ((or (eof-object? next)
- (and blank? (equal? next "")))
- (close-input-port port)
- (apply string-append (reverse acc)))
- ((equal? next "")
- (loop (read-string chunk-size port)
- #t
- (cons next acc)))
- (else
- (loop (read-string chunk-size port)
- blank?
- (cons next acc)))))))
-
-(define read-port #| (optional port) -> string
- Read PORT completely, returning the results as a string.
- PORT defaults to `current-input-port'.
- |#
- (case-lambda
- (() (%read-port (current-input-port)))
- ((p) (%read-port p))))
-
-(define (file->page file) #| string ->
- Convert FILE to an sxml tree after transforming it.
- This procedure returns both the sxml of the transformed content, but that
- page's metadata, too. |#
- (let* ((source (with-input-from-file file read-port))
- (dest (html->sxml (transform-content source))))
- (make-page (slugify file)
- (extract-meta dest)
- source
- dest
- file
- (transform-path file (build-directory)))))
-
-(define (extract-meta tree) #| sxml -> alist
- Extract metadata from TREE's comments.
- Returns an alist of (key . value) pairs where keys and values are strings. |#
- (let loop ((tree tree)
- (acc '()))
- (cond
- ((or (atom? tree)
- (null? tree))
- (reverse acc))
- ((and (list? (car tree))
- (eq? (caar tree) '*COMMENT*))
- (loop (cdr tree)
- (let* ((comment (string-trim-both (cadar tree)))
- (lines (string-split comment "\n")))
- (map (lambda (l)
- (let ((kv (string-split l ":")))
- (cons (string-trim-both (car kv))
- (string-trim
- (string-intersperse (cdr kv) ":")))))
- lines))))
- ((list? (car tree))
- (loop (cdr tree)
- (let ((subtree (loop (car tree) '())))
- (if (null? subtree)
- acc
- (cons subtree acc)))))
- (else (loop (cdr tree) acc)))))
-
-(define (meta-ref meta key default) #| alist string string ->
- Get KEY's value from META, or DEFAULT if it doesn't exist.
- DEFAULT is required because I think it's a good idea to require it. |#
- (let ((x (assoc key meta)))
- (if x (cdr x) default)))
-
-(define (page-meta-ref page key default) #| string string ->
- Get KEY's value from PAGE's meta, or DEFAULT.
- |#
- (let ((meta (page-meta page)))
- (meta-ref meta key default)))
-
-;;; Time
-;; Time really only matters in feeds ... but it really does matter. So I need a
-;; few helper functions.
-
-(define publish-time ; this is a parameter so it's consistent across a run.
- (make-parameter
- (time->string (seconds->utc-time) "%FT%TZ")))
-
-(define (page-mtime page) #| -> time-string
- Grab the mtime field from PAGE's source file. |#
- (let ((file (page-source-path page)))
- (and file
- (file-exists? file)
- (time->string (seconds->utc-time
- (file-modification-time
- file))))))
-
-(define (page-guess-updated page) #| -> time-string
- Guess the "updated" property of PAGE. |#
- (let ((meta-date (page-meta-ref page "date" #f)))
- (if meta-date
- ;; Attempt to parse the date metadata field.
- (time->string (seconds->utc-time ; This double-conversion is /great/
- (local-time->seconds
- (or (string->time meta-date "%Y-%m-%d")
- (string->time meta-date "%Y-%m-%d%n%H:%M")
- (string->time meta-date "%Y-%m-%d%n%I:%M%n%p")
- ;; ... more ?
- (or (page-mtime page)
- (publish-time))))))
- (or (page-mtime page)
- (publish-time)))))
-
-;;; Templating
-;; Templating uses sxml to define a layout for pages and indeces (index.html,
-;; feed.xml). Sxml's "stylesheets" can be used to extract metadata out of html
-;; comments and to further process the document.
-
-;; Each template has a default, but the user can override by defining templates
-;; in .config.scm (see below). All templates are function parameters that take
-;; a page's sxml tree (argument PAGE) and return a string.
-
-(define page-template
- (make-parameter
- (lambda (page)
- `(html (@ (lang "en"))
- (head (title ,(page-meta-ref page "title" "[untitled]"))
- (link (@ (href "../style.css") ; relative
- (rel "stylesheet")))
- (meta (@ (name "viewport")
- (content "initial-scale=1.0"))))
- (body ,(let ((title (page-meta-ref page "title" #f)))
- (if title `(h1 ,title) ""))
- ,@(cdr (page-dest page)))))))
-
-(define index-template
- (make-parameter
- (lambda pages
- `(html (@ (lang "en"))
- (head (title ,(site-name))
- (link (@ (href "./style.css") ; relative
- (rel "stylesheet")))
- (meta (@ (name "viewport")
- (content "initial-scale=1.0"))))
- (body (h1 ,(site-name))
- (ul
- ,@(map (lambda (pg)
- `(li (a (@ (href ,(page-slug pg)))
- ,(page-meta-ref pg
- "title"
- (pathname-file
- (page-source-path pg))))))
- ;; TODO : sort pages
- pages)))))))
-
-(define feed-template
- (make-parameter
- (lambda pages
- (make-atom-doc
- (make-feed
- title: (make-title (site-name))
- id: (site-base-url)
- updated: (publish-time) ; I don't like these semantics ..
- authors: (list (make-author name: (site-author)
- uri: (site-base-url)))
- links: (list (make-link type: 'html
- uri-language: "en"
- uri: (site-base-url))
- (make-link relation: "self"
- type: "application/atom+xml"
- uri: (make-pathname
- (site-base-url) "feed" "xml")))
- rights: (make-rights (site-rights))
- generator: (make-generator "Boudin"
- uri: "https://git.acdw.net/boudin"
- version: "0.1.0")
- entries: (map (lambda (pg)
- (make-entry
- title: (make-title
- (page-meta-ref pg "title" "[untitled]"))
- links: (list (make-link type: 'html
- uri: (page-url pg)))
- id: (page-url pg)
- updated: (page-guess-updated pg)
- ;;published:
- content: (make-content
- (sxml->html (page-dest pg))
- type: html)
- #;`(atom:content "foo")))
- pages))))))
-
-;;; Publishing
-
-(define (write-style)
- (print-log "writing style")
- (with-output-to-file (make-pathname (build-directory) "style" "css")
- (lambda () (write-css (site-style)))))
-
-(define (write-page page)
- (print-log "writing " (or (page-meta-ref page "title" #f)
- (page-source-path page)))
- (create-directory (pathname-directory (page-dest-path page)) 'parents)
- (with-output-to-file (page-dest-path page)
- (lambda () (sxml-display-as-html ((page-template) page)))))
-
-(define (write-index pages)
- (print-log "writing index")
- (with-output-to-file (make-pathname (build-directory) "index" "html")
- (lambda () (sxml-display-as-html (apply (index-template) pages)))))
-
-(define (write-feed pages)
- (print-log "writing feed")
- (serialize-sxml (apply (feed-template) pages)
- output: (make-pathname (build-directory) "feed" "xml")
- cdata-section-elements: '(atom:content)
- ns-prefixes: `((*default* . "http://www.w3.org/2005/Atom")
- (*default* . "http://www.w3.org/1999/xhtml")
- . ,(atom-ns-prefixes))
- allow-prefix-redeclarations: #t
- ))
-
-;;; Configuration
-
-;; Build configuration
-
-(define build-directory
- (make-parameter "out/"))
-
-(define build-config
- (make-parameter "config.scm"))
-
-;; Site configuration
-
-(define site-name
- (make-parameter "[A boudin web site]"))
-
-(define site-base-url
- (make-parameter "https://example.com/"))
-
-(define site-author
- (make-parameter "nobody"))
-
-(define site-rights
- (make-parameter (string-append "(C) " (site-author))))
-
-(define site-style
- (make-parameter
- `(css+ (body (font "20px/1.4 sans-serif")
- (max-width "48em")
- (padding "1em")
- (margin auto)))))
-
-;;; Options & Operands (SRFI 37)
-
-(define (print-log . xs)
- (with-output-to-port (current-error-port)
- (lambda () (apply print xs))))
-
-(define (die error-code . xs)
- (apply print-log xs)
- (exit error-code))
-
-(define usage
- (string-append
- "Usage: boudin [OPTIONS] FILE ...\n"
- "Options:\n"
- "-h, --help show this help and exit\n"
- "-o DIR, --output DIR build site to DIR (default: out/)\n"
- "Operands:\n"
- "FILE ... files to build\n"))
-
-(define opt/help
- (option '(#\h "help") ; Names
- #f ; Required arg?
- #f ; Optional arg?
- (lambda _ ; Option proc (opt name arg seeds ...)
- (die 0 usage))))
-
-(define opt/build-directory
- (option '(#\o "output") #t #f
- (lambda (opt name arg seeds)
- (build-directory arg)
- seeds)))
-
-(define opt/build-config
- (option '(#\c "config") #t #f
- (lambda (opt name arg seeds)
- (build-config arg)
- seeds)))
-
-(define (process-args args)
- (let ((pages '()))
- (args-fold args
- ;; Options
- (list opt/help
- opt/build-directory
- opt/build-config)
- ;; Unrecognized option proc (option name arg seeds ...)
- (lambda (_ name _ _)
- (die 1 "Unrecognized option: -" name "\n" usage))
- ;; Operand proc (operand seeds ...)
- (lambda (name seeds)
- (if (file-exists? name)
- (set! pages (cons name pages))
- (die 2 "File not found: " name))
- seeds)
- ;; Seeds
- '())
- pages))
-
-;;; Main entry point
-
-(define pages (make-parameter #f))
-
-(define (main args)
- (parameterize ((pages (process-args args)))
- (unless (pages)
- (die 0 "No pages to process. Abort."))
- ;; Check for files, create directories
- (if (file-exists? (build-config))
- (load (build-config))
- (print-log "No config.scm found; using default config"))
- (create-directory (build-directory) 'parents)
- ;; Convert pages to sxml. This needs to be done here because config.scm
- ;; might define functions used by the pages.
- (pages (map file->page (pages)))
- ;; Build the site
- (write-style) ; TODO: copy static assets (?)
- (for-each write-page (pages))
- (write-index (pages))
- (write-feed (pages))))
+(define (main . args)
+ (print foo)
+ (for-each print args))
(cond-expand
- ((or chicken-script compiling)
- (main (command-line-arguments)))
+ (compiling (apply main (command-line)))
(else))
diff --git a/boudin.sld b/boudin.sld
new file mode 100644
index 0000000..8129659
--- /dev/null
+++ b/boudin.sld
@@ -0,0 +1,7 @@
+(define-library (boudin)
+ (import (scheme base)
+ (scheme repl)
+ (boudin schmaltz))
+ (export hello)
+ (begin
+ (define hello "Hi")))
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))
+
+ ))
diff --git a/test/test.html b/test/test.html
deleted file mode 100644
index c78e868..0000000
--- a/test/test.html
+++ /dev/null
@@ -1,19 +0,0 @@
-
-
-some html
-(without p tags)
-
-Here is a test paragraph. example link.
-
-Here's another. I wonder if it'll just do the thing .. or whatever. Maybe I
-should try to make it multiple lines, as well.
-
-
- -
- one plus two is #(+ 1 2).
-
- - two
-
--
cgit 1.4.1-21-gabe81