A newerer beginning

6 files changed, 0 insertions, 311 deletions

@@ -1,45 +0,0 @@
-;;; (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))
-    ))
@@ -1,17 +0,0 @@
-(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"))
@@ -1,103 +0,0 @@
-;;; (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 "#<unspecified>") ; 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 "<p>" (car pars) "</p>\n")
-                  acc))))))
@@ -1,24 +0,0 @@
-(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"))
@@ -1,72 +0,0 @@
-;;; (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))))
-
-
-
@@ -1,50 +0,0 @@
-;;; (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))
-
-    ))