blob: cc9ed67eb515c3ab6ceb209aea2c91477a081955 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
;;; Haunt --- Static site generator for GNU Guile
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This file is part of Haunt.
;;;
;;; Haunt is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Haunt is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Haunt. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Post readers.
;;
;;; Code:
;; Hack to mark this module as non-declarative on Guile 3+ (which
;; would otherwise print a warning) but not break when compiling on
;; earlier versions of Guile.
(define-syntax-rule (define-module* name args ...)
(cond-expand
(guile-3
(define-module name
#:declarative? #f
args ...))
(guile
(define-module name args ...))))
(define-module* (haunt reader)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (sxml simple)
#:use-module (haunt post)
#:use-module (haunt utils)
#:export (make-reader
reader?
reader-matcher
reader-proc
reader-match?
read-post
read-posts
make-file-extension-matcher
sxml-reader
html-reader))
(define-record-type <reader>
(make-reader matcher proc)
reader?
(matcher reader-matcher)
(proc reader-proc))
(define (reader-match? reader file-name)
"Return #t if FILE-NAME is a file supported by READER."
((reader-matcher reader) file-name))
(define* (read-post reader file-name #:optional (default-metadata '()))
"Read a post object from FILE-NAME using READER, merging its
metadata with DEFAULT-METADATA."
(let-values (((metadata sxml) ((reader-proc reader) file-name)))
(make-post file-name
(append metadata default-metadata)
sxml)))
(define* (read-posts directory keep? readers #:optional (default-metadata '()))
"Read all of the files in DIRECTORY that match KEEP? as post
objects. The READERS list must contain a matching reader for every
post."
(define enter? (const #t))
(define (leaf file-name stat memo)
(if (keep? file-name)
(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)))
memo))
(define (noop file-name stat result)
result)
(define (err file-name stat errno result)
(error "file processing failed with errno: " file-name errno))
(file-system-fold enter? leaf noop noop noop err '() directory stat))
;;;
;;; Simple readers
;;;
(define (make-file-extension-matcher ext)
"Return a procedure that returns #t when a file name ends with
'.EXT'."
(let ((regexp (make-regexp (string-append "\\." ext "$"))))
(lambda (file-name)
(regexp-match? (regexp-exec regexp file-name)))))
(define sxml-reader
(make-reader (make-file-extension-matcher "sxml")
(lambda (file-name)
(let ((contents (load (absolute-file-name file-name))))
(values (alist-delete 'content contents eq?)
(assq-ref contents 'content))))))
(define (read-html-post port)
(values (read-metadata-headers port)
(let loop ()
(let ((next-char (peek-char port)))
(cond
((eof-object? next-char)
'())
((char-set-contains? char-set:whitespace next-char)
(read-char port)
(loop))
(else
(match (xml->sxml port)
(('*TOP* sxml) (cons sxml (loop))))))))))
(define html-reader
(make-reader (make-file-extension-matcher "html")
(cut call-with-input-file <> read-html-post)))
|
