ethics.lisp (5073B)
1 (defpackage :ethics 2 (:use :cl) 3 (:export #:write-ethics) 4 (:local-nicknames 5 (:md :markdown.cl) 6 (:jzon :com.inuoe.jzon))) 7 8 (in-package :ethics) 9 10 ;; --- Importing Data 11 12 (defparameter config 13 '(:build-dir #p"../build/" 14 :template-dir #p"../html/" 15 :data-dir #p"../data/" 16 :versions ("en_elwes" "la_spinoza"))) 17 18 (defun read-version (key dir tbl) 19 (format t "Reading: ~a~&" key) 20 (loop :with meta := nil 21 :for path :in (uiop:directory-files dir) 22 :as ftype := (pathname-type path) 23 :as fname := (pathname-name path) 24 :when (string= ftype "md") 25 :do (setf (gethash key (gethash fname tbl)) 26 (uiop:read-file-string path)) 27 :when (string= ftype "json") 28 :do (setf meta (jzon:parse path)) 29 :finally (return meta))) 30 31 (defun import-versions (config tbl) 32 (loop :for path :in (loop :with data-dir := (getf config :data-dir) 33 :for v :in (getf config :versions) 34 :collect (make-pathname :directory 35 (append (pathname-directory data-dir) 36 (list v)))) 37 :as fname := (car (last (pathname-directory path))) 38 :as data := (read-version fname path tbl) 39 :collect 40 (let ((v (list :key fname 41 :path path 42 :name (gethash "name" data) 43 :translator (gethash "translator" data) 44 :language (gethash "language" data) 45 :types (gethash "types" data) 46 :meta data 47 :file (make-pathname :name fname :type "html")))) 48 (format t "Version: ~S~&" v) v) 49 :into versions 50 :finally (return (cons tbl versions)))) 51 52 (defun get-nodes (tbl nodes) 53 (when nodes 54 (loop :with res := (make-array (length nodes) :fill-pointer 0) 55 :for key :across nodes 56 :as node := (gethash key tbl) 57 :do (vector-push node res) 58 :finally (return res)))) 59 60 (defun make-links (tbl id nodes) 61 (when nodes 62 (loop :for node :across nodes 63 :do (push id (gethash :links (gethash node tbl)))))) 64 65 (defun build-tree (tbl) 66 (loop :for node :being :each :hash-value :in tbl 67 :as children := (gethash "children" node) 68 :do (make-links tbl (gethash "id" node) (gethash "ref" node)) 69 (setf (gethash :child-nodes node) 70 (get-nodes tbl children)) 71 :finally (return (gethash "ethica" tbl)))) 72 73 (defun import-ethics (config) 74 (let ((tbl (jzon:parse (merge-pathnames #p"meta.json" (getf config :data-dir))))) 75 (build-tree tbl) 76 (import-versions config tbl))) 77 78 ;; --- generate html 79 80 (defun process-to-file (template outpath &rest bindings) 81 (with-open-file (out outpath 82 :direction :output 83 :external-format :utf8 84 :if-exists :supersede 85 :if-does-not-exist :create) 86 (plump:serialize 87 (apply #'clip:process 88 template 89 bindings) 90 out))) 91 92 (defun make-node (node vkey types &optional (level 1)) 93 (clip:process 94 (merge-pathnames #p"node.chtml" (getf config :template-dir)) 95 :node node 96 :level level 97 :vkey vkey 98 :types types)) 99 100 (defun write-ethics (config) 101 (destructuring-bind (ethica &rest versions) 102 (import-ethics config) 103 (process-to-file (merge-pathnames #p"index.chtml" (getf config :template-dir)) 104 (merge-pathnames #p"index.html" (getf config :build-dir)) 105 :versions versions) 106 (dolist (version versions) 107 (let ((key (getf version :key))) 108 (format t "Writing: ~a~&" key) 109 (process-to-file 110 (merge-pathnames #p "ethics.chtml" (getf config :template-dir)) 111 (merge-pathnames (getf version :file) 112 (getf config :build-dir)) 113 :tree (gethash "ethica" ethica) 114 :name (getf version :name) 115 :vkey key 116 :language (getf version :language) 117 :types (getf version :types)))))) 118 119 ;; --- plumbing 120 121 (defmacro parse-args (&rest args) 122 `(loop :with version := nil 123 :for arg :on (uiop:command-line-arguments) :by #'cddr 124 :as flag := (car arg) 125 :as value := (cadr arg) 126 :if (string= flag "--") 127 :do (setf versions (cdr arg)) 128 (loop-finish) 129 :else 130 :nconc (parse-arg flag value ,@args) :into pairs 131 :finally (return (append pairs (list :versions versions))))) 132 133 (defun parse-arg (flag value &rest args) 134 (let ((key (and (uiop:string-prefix-p "--" flag) 135 (intern (string-upcase (subseq flag 2)) 136 :keyword)))) 137 (if (member key args) 138 (list key value) 139 (error "Unrecognized command line argument: ~a ~a" flag value)))) 140 141 (defun main () 142 (let ((config (parse-args :build-dir :template-dir :data-dir))) 143 (format t "Arguments: ~a~&" config) 144 (write-ethics config))) 145