From 310cc3c621b410314c8d4448b72d0d6375dcc279 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Sun, 16 Jul 2023 23:36:51 -0500
Subject: First working version

---
 boudin.scm | 286 +++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 174 insertions(+), 112 deletions(-)

(limited to 'boudin.scm')

diff --git a/boudin.scm b/boudin.scm
index 082542b..ac22682 100755
--- a/boudin.scm
+++ b/boudin.scm
@@ -16,6 +16,7 @@ boudin --- a little static site generator
         (chicanery)
         (atom)
         (html-parser)
+        (scss)
         (srfi 37)
         (srfi 152)
         (sxpath))
@@ -97,31 +98,41 @@ boudin --- a little static site generator
             (cons (string-append "<p>" (car pars) "</p>\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* ((escaped (irregex-replace/all
-                   '(or (: #\# #\# (look-ahead (or #\{ #\()))
-                        (: #\# (look-ahead (~ #\{ #\()))
-                        (: #\# eos))
-                   str
-                   "##"))
-         (delim (let loop ((attempt (number->string (pseudo-random-real))))
+  (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 escaped)
+                    (open-input-string (preprocess-text str))
                     (open-input-string (string-append "\n" delim "\n"))))
-         (expanded (let ((x (open-output-string)))
-                     (display (eval (read template)
-                                    (interaction-environment))
-                              x)
-                     (get-output-string x))))
+         (expanded (with-output-to-string
+                     (lambda ()
+                       (display (eval (read template)
+                                      (interaction-environment)))))))
     (irregex-replace/all '(: "#<unspecified>"
                              (* whitespace))
                          expanded
@@ -149,7 +160,9 @@ boudin --- a little static site generator
   (source-path page-source-path)
   (dest-path page-dest-path (setter page-dest-path)))
 
-(define (%read-port port)
+(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)
@@ -168,7 +181,10 @@ boudin --- a little static site generator
               blank?
               (cons next acc)))))))
 
-(define read-port
+(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))))
@@ -184,7 +200,7 @@ boudin --- a little static site generator
                source
                dest
                file
-               (transform-path file (output-directory)))))
+               (transform-path file (build-directory)))))
 
 (define (extract-meta tree) #| sxml -> alist
   Extract metadata from TREE's comments.
@@ -271,85 +287,100 @@ boudin --- a little static site generator
 (define page-template
   (make-parameter
    (lambda (page)
-     (sxml->html
-      `(html (@ (lang "en"))
-             (head (title ,(page-meta-ref page "title" "[untitled]")))
-             (body ,(let ((title (page-meta-ref page "title" #f)))
-                      (if title `(h1 ,title) ""))
-                   ,@(cdr (page-dest page))))))))
+     `(html (@ (lang "en"))
+            (head (title ,(page-meta-ref page "title" "[untitled]"))
+                  (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
-     (sxml->html
-      `(html (@ (lang "en"))
-             (head (title ,(site-name)))
-             (body (h1 ,(site-name))
-                   (ul
-                    ,@(map (lambda (pg)
-                             `(li (a (@ (href ,(page-url pg)))
-                                     ,(page-meta-ref pg
-                                                     "title"
-                                                     (pathname-file
-                                                      (page-source-path pg))))))
-                           pages))))))))
+     `(html (@ (lang "en"))
+            (head (title ,(site-name)))
+            (body (h1 ,(site-name))
+                  (ul
+                   ,@(map (lambda (pg)
+                            `(li (a (@ (href ,(page-url pg)))
+                                    ,(page-meta-ref pg
+                                                    "title"
+                                                    (pathname-file
+                                                     (page-source-path pg))))))
+                          pages)))))))
 
 (define feed-template
   (make-parameter
    (lambda pages
-     (with-output-to-string
-       (lambda ()
-         (write-atom-doc
-          (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:
-                             `(atom:content (@ (type "html"))
-                                            ,(cdr (page-dest pg)))))
-                          pages)))))))))
-
-;;; Collecting pages from a directory
-
-(define (collect-pages dir ext)
-  (map file->page
-       (glob (make-pathname dir "*" ext))))
+     (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:
+                        `(atom:content (@ (type "html"))
+                                       ,(cdr (page-dest pg)))))
+                     pages))))))
 
 ;;; Publishing
 
-(define (apply-template template pages)
-  (apply template (if (list? pages)
-                      pages
-                      (list pages))))
+(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")
+  (with-output-to-file (make-pathname (build-directory) "feed" "xml")
+    (lambda () (write-atom-doc (apply (feed-template) pages)))))
 
 ;;; Configuration
 
-(define output-directory
+;; 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]"))
 
@@ -362,58 +393,89 @@ boudin --- a little static site generator
 (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 (die error-code message . args)
+(define (print-log . xs)
   (with-output-to-port (current-error-port)
-    (apply print message args)
-    (exit error-code)))
+    (lambda () (apply print xs))))
+
+(define (die error-code . xs)
+  (apply print-log xs)
+  (exit error-code))
 
-(define usage #<<END
-Usage: boudin [OPTIONS]
-Options:
--h, --help               show this help and exit
--C dir, --directory dir  build site in DIR instead of current directory
-END
-)
+(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 ...)
-            (with-output-to-port (current-error-port)
-              (lambda () (print usage)))
-            (exit))))
+            (die 0 usage))))
 
-(define opt/directory
-  (option '(#\C "directory") #t #f
+(define opt/build-directory
+  (option '(#\o "output") #t #f
           (lambda (opt name arg seeds)
-            (if (directory-exists? arg)
-                (change-directory arg)
-                (error "Directory doesn't exist" arg))
+            (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)
-  (args-fold args
-             ;; Options
-             (list opt/help
-                   opt/directory)
-             ;; Unrecognized option proc (option name arg seeds ...)
-             (lambda (_ name _ _)
-               (die 1 "Unrecognized option: -" name "\n" usage))
-             ;; Operand proc (operand seeds ...)
-             (lambda (name _)
-               (die 1 "Unrecognized operand: " name "\n" usage))
-             ;; Seeds
-             '()))
+  (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 (file->page name) pages))
+                     (die 2 "Page not found: " name))
+                 seeds)
+               ;; Seeds
+               '())
+    pages))
 
 ;;; Main entry point
 
+(define pages (make-parameter #f))
+
 (define (main args)
-  (process-args args)
-  ;; TODO ...
-  #f)
+  (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)
+    ;; Build the site
+    (write-style)                       ; TODO: copy static assets (?)
+    (for-each write-page (pages))
+    (write-index (pages))
+    (write-feed (pages))))
 
 (cond-expand
   ((or chicken-script compiling)
-- 
cgit 1.4.1-21-gabe81