From 1edd8aa07afd8a19f6c1127700fbf06f3e589196 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Aug 2015 23:09:31 -0400
Subject: site: Add a way to ignore post files that match a pattern.

This allows one to ignore files that would otherwise match a reader's
file extension, such as an Emacs temporary file like ".#foo.html".

* haunt/site.scm (<site>)[post-filter]: New field.
  (site-posts-filter): New accessor.
  (site): Add #:post-filter argument.
  (build-site): Pass post filter procedure to 'read-posts'.
  (make-file-name-filter, default-file-name-filter): New procedures.
* haunt/reader.scm (read-posts): Add 'ignore?' argument.
---
 haunt/reader.scm | 17 ++++++++++-------
 haunt/site.scm   | 29 ++++++++++++++++++++++++++---
 2 files changed, 36 insertions(+), 10 deletions(-)

diff --git a/haunt/reader.scm b/haunt/reader.scm
index 7610482..d078594 100644
--- a/haunt/reader.scm
+++ b/haunt/reader.scm
@@ -63,16 +63,19 @@ metadata with DEFAULT-METADATA."
                (append metadata default-metadata)
                sxml)))
 
-(define* (read-posts directory readers #:optional (default-metadata '()))
-  "Read all of the files in DIRECTORY as post objects.  The READERS
-list must contain a matching reader for every post."
+(define* (read-posts directory ignore? readers #:optional (default-metadata '()))
+  "Read all of the files in DIRECTORY that do not match IGNORE? as
+post objects.  The READERS list must contain a matching reader for
+every post."
   (define enter? (const #t))
 
   (define (leaf file-name stat memo)
-    (let ((reader (find (cut reader-match? <> file-name) readers)))
-      (if reader
-          (cons (read-post reader file-name default-metadata) memo)
-          (error "no reader available for post: " file-name))))
+    (if (ignore? file-name)
+        memo
+        (let ((reader (find (cut reader-match? <> file-name) readers)))
+          (if reader
+              (cons (read-post reader file-name default-metadata) memo)
+              (error "no reader available for post: " file-name)))))
 
   (define (noop file-name stat result)
     result)
diff --git a/haunt/site.scm b/haunt/site.scm
index e6604cb..44fd6b3 100644
--- a/haunt/site.scm
+++ b/haunt/site.scm
@@ -23,9 +23,11 @@
 ;;; Code:
 
 (define-module (haunt site)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (haunt utils)
   #:use-module (haunt reader)
   #:use-module (haunt page)
@@ -36,21 +38,26 @@
             site-title
             site-domain
             site-posts-directory
+            site-post-filter
             site-build-directory
             site-default-metadata
             site-make-slug
             site-readers
             site-builders
             site-post-slug
-            build-site))
+            build-site
+
+            make-file-name-filter
+            default-file-name-filter))
 
 (define-record-type <site>
-  (make-site title domain posts-directory build-directory
+  (make-site title domain posts-directory post-filter build-directory
              default-metadata make-slug readers builders)
   site?
   (title site-title)
   (domain site-domain)
   (posts-directory site-posts-directory)
+  (post-filter site-post-filter)
   (build-directory site-build-directory)
   (default-metadata site-default-metadata)
   (make-slug site-make-slug)
@@ -61,6 +68,7 @@
                (title "This Place is Haunted")
                (domain "example.com")
                (posts-directory "posts")
+               (post-filter default-file-name-filter)
                (build-directory "site")
                (default-metadata '())
                (make-slug post-slug)
@@ -70,13 +78,15 @@
 
 TITLE: The name of the site
 POSTS-DIRECTORY: The directory where posts are found
+POST-FILTER: A predicate procedure that returns #t when a post file
+should be ignored (ignores Emacs temp files by default)
 BUILD-DIRECTORY: The directory that generated pages are stored in
 DEFAULT-METADATA: An alist of arbitrary default metadata for posts
 whose keys are symbols
 MAKE-SLUG: A procedure generating a file name slug from a post
 READERS: A list of reader objects for processing posts
 BUILDERS: A list of procedures for building pages from posts"
-  (make-site title domain posts-directory build-directory
+  (make-site title domain posts-directory post-filter build-directory
              default-metadata make-slug readers builders))
 
 (define (site-post-slug site post)
@@ -86,6 +96,7 @@ BUILDERS: A list of procedures for building pages from posts"
 (define (build-site site)
   "Build SITE in the appropriate build directory."
   (let ((posts (read-posts (site-posts-directory site)
+                           (site-post-filter site)
                            (site-readers site)
                            (site-default-metadata site)))
         (build-dir (absolute-file-name (site-build-directory site))))
@@ -104,3 +115,15 @@ BUILDERS: A list of procedures for building pages from posts"
                (obj
                 (error "unrecognized site object: " obj)))
               (flat-map (cut <> site posts) (site-builders site)))))
+
+(define (make-file-name-filter patterns)
+  (let ((patterns (map make-regexp patterns)))
+    (lambda (file-name)
+      (any (lambda (regexp)
+             (regexp-match?
+              (regexp-exec regexp (basename file-name))))
+           patterns))))
+
+;; Filter out Emacs temporary files by default.
+(define default-file-name-filter
+  (make-file-name-filter '("^\\.#")))
-- 
cgit v1.2.3