Commit 21905dbb authored by Erik Huelsmann's avatar Erik Huelsmann

Introduce macrology to simplify definition and invocation of wrappers

parent fc5ae7fb
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(in-package :cl-site) (in-package :cl-site)
; Makes pathname from prefix + page object
(defun make-path (prefix suffix &optional page) (defun make-path (prefix suffix &optional page)
"Constructs a pathname from `prefix` and `suffix`.
`suffix` can be one of
1. a context (an alist) with a ':content' element
2. a pathname
3. a string identifying a path
`prefix` can be one of
1. a pathname
2. a string identifying a path
"
(let ((path (if page (cdr (assoc :content suffix)) suffix))) (let ((path (if page (cdr (assoc :content suffix)) suffix)))
(if (pathnamep prefix) (if (pathnamep prefix)
(merge-pathnames path prefix) (merge-pathnames path prefix)
(pathname (concatenate 'string (pathname (concatenate 'string
prefix path))))) prefix path)))))
; Slurps file from a string
(defun file-to-string (filepath) (defun file-to-string (filepath)
"Reads the file designated by pathname `filepath` into memory,
returning the string with the sequence read from the file"
(with-open-file (stream filepath) (with-open-file (stream filepath)
(let ((data (make-string (file-length stream)))) (let ((data (make-string (file-length stream))))
(read-sequence data stream) (read-sequence data stream)
data))) data)))
(defun header-lines (lines)
"Returns a list of lines (subset of `lines`)
which form the header of the document `lines` were read from
"
(loop for line in lines
thereis (when (string= line "---") header-lines)
collect line into header-lines))
(defun content-lines (lines)
"Returns a list of lines (subset of `lines`)
which remain after the header (if any) has been discarded
"
(loop with found-header-p = nil
for line in lines
when found-header-p
collect line into post-header-lines
when (string= line "---")
do (setf found-header-p t)
collect line into content-lines
finally (return (if found-header-p post-header-lines content-lines))))
(defun populate-pages () (defun populate-pages ()
"Each page is an alist containing info to be sent to the template via the context." "Each page is an alist containing info to be sent to the template via the context."
(mapcar (lambda (p) (mapcar (lambda (p)
...@@ -31,6 +63,35 @@ ...@@ -31,6 +63,35 @@
(directory (merge-pathnames #P"**/*.lisp" *pages-dir*))))) (directory (merge-pathnames #P"**/*.lisp" *pages-dir*)))))
(defvar *render-hooks* '()
"A list of hooks wrapping the rendering of the page.")
(defmacro def-render-hook (name (&rest args) &rest body)
"Registers a hook to wrap the rendering of the page.
Provides a `call-next-hook` function which dispatches
execution to the next wrapper and ultimately to the
page renderer.
The wrapper should return the value received from
a `call-next-hook` to its caller as it is the content
of the rendered page.
"
`(progn
(defun ,name (,@args next-hooks)
(flet ((call-next-hook (content context)
(funcall (pop next-hooks) content context next-hooks)))
,@body))
(push (function ,name) *render-hooks*)))
(defun render-page-with-hooks (content context)
(let ((hooks (reverse (cons #'(lambda (p c next-processors)
(process-page p c))
*render-hooks*))))
(funcall (pop hooks) content context hooks)))
(defun page-content (page) (rest (assoc :content page))) (defun page-content (page) (rest (assoc :content page)))
......
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(in-package :cl-site) (in-package :cl-site)
(defun header-lines (lines)
(loop for line in lines
thereis (when (string= line "---") header-lines)
collect line into header-lines))
(defun content-lines (lines)
(loop with found-header-p = nil
for line in lines
when found-header-p
collect line into post-header-lines
when (string= line "---")
do (setf found-header-p t)
collect line into content-lines
finally (return (if found-header-p post-header-lines content-lines))))
(defun make-site (&optional output-dir) (defun make-site (&optional output-dir)
(let ((*output-dir* (or output-dir *output-dir*)) (let ((*output-dir* (or output-dir *output-dir*))
...@@ -52,12 +38,8 @@ ...@@ -52,12 +38,8 @@
and do (format t "Delayed rendering ~a~%" rel-page-path) and do (format t "Delayed rendering ~a~%" rel-page-path)
when satisfies-deps-p when satisfies-deps-p
do (progn do (progn
(format t "Rendering ~A~%" rel-page-path)) (format t "Rendering ~A~%" rel-page-path)
(preprocess-md-page content context (render-page-with-hooks content context))
(list #'preprocess-lisp-page
#'generate-news
(lambda (p c next-processors)
(process-page p c))))
and collect rel-page-path into processed-pages and collect rel-page-path into processed-pages
and do (loop for resolved-deps-pages = and do (loop for resolved-deps-pages =
(loop for delay in delayed-pages (loop for delay in delayed-pages
...@@ -67,11 +49,7 @@ ...@@ -67,11 +49,7 @@
and do (progn and do (progn
(format t "Rendering delayed ~a~%" (fourth delay)) (format t "Rendering delayed ~a~%" (fourth delay))
(push (fourth delay) processed-pages) (push (fourth delay) processed-pages)
(preprocess-md-page (second delay) (third delay) (render-page-with-hooks (second delay) (third delay))))
(list #'preprocess-lisp-page
#'generate-news
(lambda (p c next-processors)
(process-page p c))))))
while resolved-deps-pages while resolved-deps-pages
do (setf delayed-pages do (setf delayed-pages
(set-difference delayed-pages resolved-deps-pages :key #'fourth :test #'string=)))))) (set-difference delayed-pages resolved-deps-pages :key #'fourth :test #'string=))))))
......
...@@ -47,21 +47,21 @@ ...@@ -47,21 +47,21 @@
page-context) page-context)
stream)))))) stream))))))
(defun preprocess-md-page (content context next-processors) (def-render-hook preprocess-md-page (content context)
(let* ((md-file (enough-namestring (make-path *pages-dir* context t) *pages-dir*))) (let* ((md-file (enough-namestring (make-path *pages-dir* context t) *pages-dir*)))
(unless (string= (pathname-type md-file) "md") (unless (string= (pathname-type md-file) "md")
(return-from preprocess-md-page (funcall (pop next-processors) content context next-processors))) (return-from preprocess-md-page (call-next-hook content context)))
(let ((html-file (make-pathname :defaults md-file :type "html"))) (let ((html-file (make-pathname :defaults md-file :type "html")))
(format t "Transforming ~A to ~A~%" md-file html-file) (format t "Transforming ~A to ~A~%" md-file html-file)
(let ((md-content (with-output-to-string (let ((md-content (with-output-to-string
(out) (out)
(cl-markdown:markdown content :stream out)))) (cl-markdown:markdown content :stream out))))
(funcall (pop next-processors) md-content context next-processors))))) (call-next-hook md-content context)))))
(defun preprocess-lisp-page (content context next-processors) (def-render-hook preprocess-lisp-page (content context)
(let* ((lisp-file (make-path *pages-dir* context t))) (let* ((lisp-file (make-path *pages-dir* context t)))
(unless (string= (pathname-type lisp-file) "lisp") (unless (string= (pathname-type lisp-file) "lisp")
(return-from preprocess-lisp-page (funcall (pop next-processors) content context next-processors))) (return-from preprocess-lisp-page (call-next-hook content context)))
(let ((html-file (enough-namestring (make-pathname :defaults lisp-file :type "html") *pages-dir*)) (let ((html-file (enough-namestring (make-pathname :defaults lisp-file :type "html") *pages-dir*))
*computed-page-content*) *computed-page-content*)
(format t "Loading ~a and creating fresh ~a...~%" (format t "Loading ~a and creating fresh ~a...~%"
...@@ -69,13 +69,12 @@ ...@@ -69,13 +69,12 @@
;;;###TODO not happy about loading the lisp file; it defeats the preprocessor/postprocessor purpose ;;;###TODO not happy about loading the lisp file; it defeats the preprocessor/postprocessor purpose
(load (merge-pathnames lisp-file *pages-dir*)) (load (merge-pathnames lisp-file *pages-dir*))
(let ((headers (getf *computed-page-content* :headers))) (let ((headers (getf *computed-page-content* :headers)))
(funcall (pop next-processors) (getf *computed-page-content* :html-string) (call-next-hook (getf *computed-page-content* :html-string)
(append (mapcan #'(lambda (key value) (append (mapcan #'(lambda (key value)
(acons key value nil)) (acons key value nil))
(plist-keys headers) (plist-keys headers)
(plist-values headers)) (plist-values headers))
context) context))))))
next-processors)))))
(defun process-page (content context) (defun process-page (content context)
(let ((template-path (pathname (merge-pathnames *templates-dir* *DEFAULT-PAGE-TEMPLATE*)))) (let ((template-path (pathname (merge-pathnames *templates-dir* *DEFAULT-PAGE-TEMPLATE*))))
...@@ -92,9 +91,9 @@ ...@@ -92,9 +91,9 @@
;; newsbox. The news.lisp would have to include the hardcoded HTML ;; newsbox. The news.lisp would have to include the hardcoded HTML
;; which is injected below as well. ;; which is injected below as well.
;; ;;
(defun generate-news (content context next-processors) (def-render-hook generate-news (content context)
(let ((page-path (cdr (assoc :content context))) (let ((page-path (cdr (assoc :content context)))
(content (funcall (pop next-processors) content context next-processors))) (content (call-next-hook content context)))
(when (and (string= (pathname-name page-path) "news") (when (and (string= (pathname-name page-path) "news")
(string= (pathname-type page-path) "md")) (string= (pathname-type page-path) "md"))
(let ((newsbox (generate-news-box-content content))) (let ((newsbox (generate-news-box-content content)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment