paged-blog.scm 1.45 KB
Newer Older
Philip Kaludercic's avatar
Philip Kaludercic committed
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
(define-module (local micronews paged-blog)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 receive)
  #:use-module (haunt builder blog)
  #:use-module (haunt page)
  #:use-module (haunt site)
  #:use-module (haunt post)
  #:use-module (haunt html)
  #:export (paged-blog))

(define* (paged-blog #:key theme prefix (per-page 3))
  "Return a builder that creates a blog with PER-PAGE posts per page
listing. 

See (haunt builder blog)'s blog for more details."
  (define (shorter-than lst n)
	(cond ((null? lst) (positive? n))
		  ((zero? n) (null? lst))
		  (else (shorter-than (cdr lst) (1- n)))))

  (define (group-by lst n)
	(if (shorter-than lst n)
		(list lst)
		(receive (head rest) (split-at lst n)
		  (cons head (group-by rest n)))))
  
  (lambda (site posts)
	(let* ((sorted (posts/reverse-chronological posts))
		   (grouped (group-by posts per-page))
		   (last-group-nr (length grouped)))

	  (define (create-index-page group i)
		(let ((title (format #f "faui2k17 - Page ~d" i)))
		  (make-page
		   ;; file name
		   (if (= i 1)
			   "index.html"
			   (format #f "page-~d.html" i))
		   ;; content
		   ((theme-layout theme) site title
			((theme-collection-template theme)
			 site title group prefix i (= i last-group-nr)))
		   ;; function
		   sxml->html)))
	  
	  (append
	   ;; index pages
	   (map create-index-page grouped (map 1+ (iota (length grouped))))
	   ;; blog pages
	   ((blog #:theme theme #:prefix prefix
			  #:collections '())
		site posts)))))