From: Lucian Mogosanu <lucian.mogosanu@gmail.com>
Date: Sun, 23 Jun 2019 11:37:58 +0000 (+0300)
Subject: Add some basic support for coad snippets
X-Git-Tag: v0.11~42
X-Git-Url: https://git.mogosanu.ro/?a=commitdiff_plain;h=f52a294f63bd620af00dde2840550eaca06ac11c;p=thetarpit.git

Add some basic support for coad snippets
---

diff --git a/blog.lisp b/blog.lisp
index b08ba39..a9af93e 100644
--- a/blog.lisp
+++ b/blog.lisp
@@ -40,51 +40,56 @@
 (load (concatenate 'string *lbs-base* "templates/index.lisp"))
 (load (concatenate 'string *lbs-base* "templates/archive.lisp"))
 (load (concatenate 'string *lbs-base* "templates/drafts.lisp"))
+(load (concatenate 'string *lbs-base* "templates/coad.lisp"))
 (load (concatenate 'string *lbs-base* "templates/rss.lisp"))
 
 ;; TLBS functions
 ;;
 ;; TODO: Move them to an ASDF project
-(defun get-plain-text (path)
+(defun get-plain-text (path &key read-header)
   (let ((blist (make-hash-table :test 'equal)))
     (with-open-file (stream path)
-      ; First read the header: ignore everything until the first line
-      ; with three dashes
-      (do ((line (read-line stream) (read-line stream)))
-          ((equal line "---")))
-
-      ; Now read variables and add them to the blist
-      (do ((line (read-line stream) (read-line stream)))
-          ((equal line "---"))
-        (let ((pair (cl-ppcre:split ":\\s*" line :limit 2)))
-          (if (not (cdr pair))
-              (format t "Error parsing line: ~a" line)
-              (setf (gethash (car pair) blist) (cadr pair)))))
-
-      ; Now all that's left to read is the page body
-      ;
-      ; Note that we build a new string with the length exactly equal to
-      ; the file's length minus what we have read so far.
+      (when read-header
+       ;; First read the header: ignore everything until the first line
+       ;; with three dashes
+       (do ((line (read-line stream) (read-line stream)))
+           ((equal line "---")))
+
+       ;; Now read variables and add them to the blist
+       (do ((line (read-line stream) (read-line stream)))
+           ((equal line "---"))
+         (let ((pair (cl-ppcre:split ":\\s*" line :limit 2)))
+           (if (not (cdr pair))
+               (format t "Error parsing line: ~a" line)
+               (setf (gethash (car pair) blist) (cadr pair))))))
+
+      ;; Now all that's left to read is the page body
+      ;;
+      ;; Note that we build a new string with the length exactly equal
+      ;; to the file's length minus what we have read so far.
       (let ((body (make-string (file-length stream))))
         (read-sequence body stream)
         (setf (gethash "body" blist) (string-trim '(#\Nul) body)))
 
-      ; Return the new blist
+      ;; Return the new blist
       blist)))
 
+(defun tlbs-make-blist% (in-path out-path uri &key read-header)
+  (let ((blist (get-plain-text in-path :read-header read-header)))
+    (setf (gethash "in-path" blist) in-path
+          (gethash "out-path" blist) out-path
+          (gethash "uri" blist) uri)
+    blist))
+
 (defun tlbs-make-blist (relative-pathname)
   (let* ((in-path (concat-pathnames (pathname *lbs-base*)
-                                   relative-pathname))
+                                    relative-pathname))
          (out-path (post-out-extension
                     (concat-pathnames (pathname *lbs-site*)
                                       relative-pathname)))
          (uri (namestring (post-out-extension
-                           (concat-pathnames #p"/" relative-pathname))))
-         (blist (get-plain-text in-path)))
-    (setf (gethash "in-path" blist) in-path)
-    (setf (gethash "out-path" blist) out-path)
-    (setf (gethash "uri" blist) uri)
-    blist))
+                           (concat-pathnames #p"/" relative-pathname)))))
+    (tlbs-make-blist% in-path out-path uri :read-header t)))
 
 (defun tlbs-write-blist (blist)
   (with-open-file (out (ensure-directories-exist (gethash "out-path" blist))
@@ -160,6 +165,27 @@
     ; continue with normal page processing
     (tlbs-process-page (gethash "out-path" blist) blist)))
 
+(defun tlbs-process-coad-file (in-path relative-pathname &key lang)
+  (let* ((out-path (post-out-extension
+                    (concat-pathnames (pathname *lbs-site*)
+                                      relative-pathname)))
+         (uri (namestring (post-out-extension
+                           (concat-pathnames #p"/" relative-pathname))))
+         (blist (tlbs-make-blist% in-path out-path uri :read-header nil)))
+    ;; Set language
+    (setf (gethash "lang" blist) lang)
+    ;; Make fenced code block
+    (tlbs-make-coad blist)
+    ;; Apply layout
+    (tlbs-make-default blist)
+    ;; write to file
+    (tlbs-write-blist blist)
+    ;; make sure body is erased when done writing
+    ;; XXX: the body might still be needed when generating RSS
+    (setf (gethash "body" blist) nil)
+    ;;
+    nil))
+
 (defun tlbs-process-archive ()
   (tlbs-process-page (merge-pathnames
                       (pathname *lbs-site*)
diff --git a/templates/coad.lisp b/templates/coad.lisp
new file mode 100644
index 0000000..a0d8462
--- /dev/null
+++ b/templates/coad.lisp
@@ -0,0 +1,31 @@
+;; Tarpit Lisp Blog Scaffolding -- code page generation
+;;
+;; Given the path to a file, turn it into a HTML representation of
+;; itself:
+;;
+;; - read the file -> CODE
+;; - encase CODE in markdown code blocks
+;; - markdown -> html
+;; - encase in selection span
+(defun tlbs-make-coad (blist)
+  (let* ((body (gethash "body" blist))
+         (lang (gethash "lang" blist))
+         (md-code-block
+          (concatenate 'string
+                       (format nil "~4~")
+                       (if lang (format nil " {.~a}" lang) "")
+                       (format nil "~%~a~%" body)
+                       (format nil "~4~"))))
+    ;; Set code block as body
+    (setf (gethash "body" blist) md-code-block)
+    ;; Pandoc
+    (pipe-through-pandoc blist))
+  ;; Encase in shash
+  (let ((new-body
+         (with-output-to-string (out)
+           (cl-who:with-html-output (out nil :indent nil)
+             (cl-who:htm (:span :id "shash"
+                                (cl-who:str (gethash "body" blist))))))))
+    (setf (gethash "body" blist) new-body))
+  blist)
+