From 11a3e70657ffe2727ed0d1164e77c6c9b3420cf4 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 11 Apr 2015 15:01:40 -0400
Subject: site: Add build-site procedure.

* haunt/utils.scm (absolute-file-name, clean-directory): New procedures.
* haunt/site.scm (build-site): New procedure.
---
 haunt/site.scm  | 20 +++++++++++++++++++-
 haunt/utils.scm | 16 +++++++++++++++-
 2 files changed, 34 insertions(+), 2 deletions(-)

diff --git a/haunt/site.scm b/haunt/site.scm
index b731e9b..e686ecf 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -24,6 +24,10 @@
 
 (define-module (haunt site)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (haunt utils)
+  #:use-module (haunt reader)
+  #:use-module (haunt page)
   #:export (site
             site?
             site-title
@@ -31,7 +35,8 @@
             site-build-directory
             site-default-metadata
             site-readers
-            site-builders))
+            site-builders
+            build-site))
 
 (define-record-type <site>
   (make-site title posts-directory build-directory default-metadata
@@ -62,3 +67,16 @@ READERS: A list of reader objects for processing posts
 BUILDERS: A list of procedures for building pages from posts"
   (make-site title posts-directory build-directory
              default-metadata readers builders))
+
+(define (build-site site)
+  "Build SITE in the appropriate build directory."
+  (let ((posts (read-posts (site-posts-directory site)
+                           (site-readers site)
+                           (site-default-metadata site)))
+        (build-dir (absolute-file-name (site-build-directory site))))
+    (clean-directory build-dir)
+    (for-each (lambda (page)
+                (format #t "writing ~a" (page-file-name page))
+                (write-page page build-dir)
+                (format #t " ✓~%"))
+              (flat-map (cut <> site posts) (site-builders site)))))
diff --git a/haunt/utils.scm b/haunt/utils.scm
index 504d6e2..8923e13 100644
--- a/haunt/utils.scm
+++ b/haunt/utils.scm
@@ -29,7 +29,9 @@
   #:use-module (srfi srfi-26)
   #:export (flatten
             flat-map
-            string-split-at))
+            string-split-at
+            absolute-file-name
+            clean-directory))
 
 (define* (flatten lst #:optional depth)
   "Return a list that recursively concatenates the sub-lists of LST,
@@ -56,3 +58,15 @@ flattened."
               (string-drop str (1+ i)))
         (list str))))
 
+(define (absolute-file-name file-name)
+  (if (absolute-file-name? file-name)
+      file-name
+      (string-append (getcwd) "/" file-name)))
+
+(define (clean-directory dir)
+  (define (delete-other-files file-name stat flag)
+    (unless (string=? dir file-name)
+      (delete-file file-name))
+    #t)
+
+  (ftw dir delete-other-files))
-- 
cgit v1.2.3