commit 80f0856b7d8892f253f6fdc3d6bea44df473d5a8
parent b4f6e20ff3862358a8e106920422b3396b3a8da7
Author: Decay <decaydjk@tilde.town>
Date: Fri, 7 Feb 2020 23:41:58 +0000
Initial implementation of archive dates
Diffstat:
2 files changed, 65 insertions(+), 42 deletions(-)
diff --git a/src/content.lisp b/src/content.lisp
@@ -1,12 +1,13 @@
(in-package :miniblog.content)
(defun make-generator (&optional title)
- (lambda (entries &key year month tz)
+ (lambda (entries &key year month archive-date-list tz)
(execute-emb
"default-template"
:env (list
:title title
:posts entries
+ :archive-date-list archive-date-list
:content-formatter (miniblog.format:make-content-formatter)
:short-date-formatter (miniblog.format:make-short-date-formatter (or tz *default-timezone*))
:long-date-formatter (miniblog.format:make-long-date-formatter (or tz *default-timezone*))))))
@@ -56,25 +57,47 @@
(cdr entries) year month tz)))
(cons (cons (car entries) (car collected)) (cdr collected)))))))
+(defun get-archive-date-list (entries tz)
+ (labels
+ ((get-year-month-pair-for-entry (entry)
+ (let* ((real-tz (or tz *default-timezone*))
+ (created-at (nth 1 entry))
+ (year (timestamp-year created-at :timezone real-tz))
+ (month (timestamp-month created-at :timezone real-tz)))
+ (cons year month)))
+ (year-month-pairs-equal-p (a b)
+ (and (= (car a) (car b)) (= (cdr a) (cdr b)))))
+ (remove-duplicates
+ (mapcar #'get-year-month-pair-for-entry entries)
+ :test #'year-month-pairs-equal-p)))
+
(defun gen-all (entries &key generator tz)
(labels
- ((gen-all-years (entries next-year generator tz)
- (let ((year (gen-year entries next-year :generator generator :tz tz)))
- (if (cdr year)
- (append
- (car year)
- (gen-all-years
- (cdr year)
- (car (year-month-of-latest-entry (cdr year) :tz tz))
- generator tz))
- (car year)))))
- (cons
- (list :index :index (gen-index entries :generator generator :tz tz))
- (gen-all-years
- entries (car (year-month-of-latest-entry entries :tz tz))
- generator tz))))
+ ((gen-all-years (entries archive-date-list generator tz)
+ (format t "ENTRIES ~a~%ARC ~a~%" entries archive-date-list)
+ (let ((rest-entries (copy-list entries))
+ (content '()))
+ (loop for year-month in archive-date-list do
+ (let ((month-content
+ (gen-month rest-entries (car year-month) (cdr year-month)
+ :archive-date-list archive-date-list
+ :generator generator
+ :tz tz)))
+ (setf rest-entries (cdr month-content))
+ (setf content
+ (nconc content (list (car month-content))))))
+ content)))
+ (let ((archive-date-list (get-archive-date-list entries tz)))
+ (cons
+ (list :index :index (gen-index-impl entries
+ archive-date-list
+ :generator generator
+ :tz tz))
+ (gen-all-years
+ entries archive-date-list
+ generator tz)))))
-(defun gen-index (entries &key generator tz)
+(defun gen-index-impl (entries archive-date-list &key generator tz)
(if (not entries)
(funcall (or generator (make-generator)) nil :tz tz)
(let* ((year-month (year-month-of-latest-entry entries :tz tz))
@@ -83,12 +106,18 @@
(latest-month-entries (collect-entries-for-month entries entry-year entry-month tz)))
(funcall (or generator (make-generator))
(car latest-month-entries)
+ :archive-date-list archive-date-list
:tz tz))))
-(defun gen-year (entries year &key generator tz)
+(defun gen-index (entries &key generator tz)
+ (gen-index-impl entries (get-archive-date-list entries tz)
+ :generator generator :tz tz))
+
+(defun gen-year (entries year &key archive-date-list generator tz)
(labels
((gen-month-and-earlier (entries year month tz)
(let ((this-month (gen-month entries year month
+ :archive-date-list archive-date-list
:generator generator
:tz tz)))
(if (> month 1)
@@ -106,7 +135,7 @@
(cdr this-month))))))
(gen-month-and-earlier entries year 12 tz)))
-(defun gen-month (entries year month &key generator tz)
+(defun gen-month (entries year month &key archive-date-list generator tz)
(let* ((entries-at-month (monthcdr entries year month tz))
(collected (collect-entries-for-month
entries-at-month year month tz))
@@ -119,6 +148,7 @@
month-entries
:year year
:month month
+ :archive-date-list archive-date-list
:tz tz))
nil)
rest-entries)))
diff --git a/src/template.lhtml b/src/template.lhtml
@@ -35,34 +35,27 @@
<% @endif %>
<nav>
<% @if archive-date-list %>
- <% (let ((arc (copy-list (getf env :archive-date-list)))) %>
- <% (loop while arc do %>
- <div class="cal-title"><%= (car (car arc)) %></div>
- <%
+ <%
+ (let ((arc (copy-list (getf env :archive-date-list))))
+ (loop while arc do
+ (format t "<div class=\"cal-title\">~a</div>" (caar arc))
(let ((month-entries '())
(month-names '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
- (loop for cal-month from 12 to 1 do
- (if (= cal-month (cdr (car arc)))
+ (loop for cal-month downfrom 12 to 1 do
+ (if (and arc (= cal-month (cdar arc)))
(progn
- (push (format nil "~d/~2,'0d/index.html" (car (car arc)) (cdr (car arc))) month-entries)
+ (push (format nil "~d/~2,'0d/index.html" (caar arc) (cdar arc)) month-entries)
(pop arc))
(push nil month-entries)))
- (loop for row from 0 to 2 do %>
- <div class="cal-row">
- <% (loop for cal-month from (* row 4) to (+ (* row 4) 3) do %>
- <span class="cal-cell">
- <%
- (if (nth cal-month month-entries)
- (format t "<a href=\"~a\">~a</a>" (nth cal-month month-entries) (nth cal-month month-names))
- (format t "~A" (nth cal-month month-names)))
- %>
- </span>
- <% ) %>
- </div>
- <% ) %>
- <% ) %>
- <% ) %>
- <% ) %>
+ (loop for row from 0 to 2 do
+ (format t "<div class=\"cal-row\">~%")
+ (loop for cal-month from (* row 4) to (+ (* row 4) 3) do
+ (format t "<span class=\"cal-cell\">")
+ (if (nth cal-month month-entries)
+ (format t "<a href=\"~a\">~a</a>" (nth cal-month month-entries) (nth cal-month month-names))
+ (format t "~A" (nth cal-month month-names)))
+ (format t "</span>~%"))
+ (format t "</div>~%"))))) %>
<% @endif %>
</nav>
</body>
