Parse calendar months, days, quarters and day-periods

Author: ak-coram

chronogram-cldr-parser.lisp

@@ -2,9 +2,82 @@
 
 (defpackage #:chronogram-cldr-parser
   (:use #:cl #:esrap)
+  (:local-nicknames (:jzon :com.inuoe.jzon))
   (:export #:parse-cldr))
 
 (in-package #:chronogram-cldr-parser)
 
-(defun parse-cldr (contents)
-  'test)
+(defun clss-select-first (selector node)
+  (let ((results (clss:select selector node)))
+    (when (plusp (length results))
+      (elt results 0))))
+
+(defmacro defun-process-entities (entity selector value-form)
+  (let ((sym (intern (string-upcase entity))))
+    (alexandria:with-gensyms (entity-type)
+      `(defun ,(intern (concatenate 'string "PROCESS-" (string-upcase entity)))
+           (entity-parent)
+         (jzon:with-object*
+           (loop :for ,sym :across (clss:select ,selector entity-parent)
+                 :for ,entity-type := (plump:get-attribute ,sym "type")
+                 :when ,entity-type
+                   :do (progn
+                         (jzon:write-key* ,entity-type)
+                         ,value-form)))))))
+
+;; Months
+(defun-process-entities month "month"
+  (jzon:write-value* (plump:text month)))
+(defun-process-entities month-width "monthWidth"
+  (process-month month-width))
+(defun-process-entities month-context "months > monthContext"
+  (process-month-width month-context))
+
+;; Days
+(defun-process-entities day "day"
+  (jzon:write-value* (plump:text day)))
+(defun-process-entities day-width "dayWidth"
+  (process-day day-width))
+(defun-process-entities day-context "days > dayContext"
+  (process-day-width day-context))
+
+;; Quarters
+(defun-process-entities quarter "quarter"
+  (jzon:write-value* (plump:text quarter)))
+(defun-process-entities quarter-width "quarterWidth"
+  (process-quarter quarter-width))
+(defun-process-entities quarter-context "quarters > quarterContext"
+  (process-quarter-width quarter-context))
+
+;; Day periods
+(defun-process-entities day-period "dayPeriod"
+  (jzon:write-value* (plump:text day-period)))
+(defun-process-entities day-period-width "dayPeriodWidth"
+  (process-day-period day-period-width))
+(defun-process-entities day-period-context "dayPeriods > dayPeriodContext"
+  (process-day-period-width day-period-context))
+
+;; Calendars
+
+(defun-process-entities calendar "ldml > dates > calendars > calendar"
+  (jzon:with-object*
+    (jzon:write-key* "months")
+    (process-month-context calendar)
+
+    (jzon:write-key* "days")
+    (process-day-context calendar)
+
+    (jzon:write-key* "quarters")
+    (process-quarter-context calendar)
+
+    (jzon:write-key* "day-periods")
+    (process-day-period-context calendar)))
+
+(defun parse-cldr (contents out-stream)
+  (let ((root (plump:parse contents)))
+    (jzon:with-writer* (:stream out-stream :pretty nil)
+      (jzon:with-object*
+        (jzon:write-key* "calendars")
+        (process-calendar root)))))
+
+

chronogram-dist.lisp

@@ -15,21 +15,52 @@
   (format nil "https://github.com/unicode-org/cldr/archive/refs/tags/~a.zip" tag))
 
 (defun make-chronogram-info (contents dist-dir name)
-  (with-open-file (stream (format nil "~a~a.lisp" dist-dir name)
+  (with-open-file (stream (format nil "~a~a.json" dist-dir name)
                           :direction :output
                           :if-exists :supersede
                           :if-does-not-exist :create)
     (let ((*package* (find-package 'chronogram-cldr-parser)))
-      (format stream "~s~%" (chronogram-cldr-parser:parse-cldr contents)))))
+      (chronogram-cldr-parser:parse-cldr contents
+                                         stream))))
 
 (defun make-dist (&optional force-download)
   (let* ((system (asdf:find-system 'chronogram t))
          (dist-dir (asdf:system-relative-pathname system "chronogram-dist/"))
-         (tz-submodule-available
+         (cldr-submodule-available
            (uiop:file-exists-p
-            (asdf:system-relative-pathname system "cldr/LICENSE")))
-         (tag (when (or force-download (not tz-submodule-available))
-                (get-cldr-release-tag system))))
+            (asdf:system-relative-pathname system "cldr/unicode-license.txt")))
+         (tag (when (or force-download (not cldr-submodule-available))
+                (get-cldr-release-tag system)))
+         (names '("en" "de" "hu" "ko")))
     (ensure-directories-exist dist-dir)
-    ;; DUMMY
-    (make-chronogram-info "" dist-dir "test")))
+    (if tag
+        (uiop:with-temporary-file (:stream s)
+          (format t "Downloading cldr release ~a... " tag)
+          (force-output)
+          (let ((bytes (dex:get (get-archive-url tag))))
+            (write-sequence bytes s)
+            (finish-output s))
+          (format t "DONE~%")
+          (zip:with-zipfile (f s)
+            (loop :for name :in names
+                  :for entry := (zip:get-zipfile-entry
+                                 (format nil "cldr-~a/~a" tag name) f)
+                  :do (format t "Writing ~a~a.json... " dist-dir name)
+                  :do (force-output)
+                  :do (make-chronogram-info
+                       (babel:octets-to-string (zip:zipfile-entry-contents entry)
+                                               :encoding :utf-8)
+                       dist-dir
+                       name)
+                  :do (format t "DONE~%"))))
+        (loop :with cldr-dir := (asdf:system-relative-pathname system "cldr/")
+              :for name :in names
+              :do (format t "Writing ~a~a.json... " dist-dir name)
+              :do (force-output)
+              :do (make-chronogram-info
+                   (uiop:read-file-string (format nil "~a/common/main/~a.xml"
+                                                  cldr-dir
+                                                  name))
+                   dist-dir
+                   name)
+              :do (format t "DONE~%")))))

chronogram.asd

@@ -12,7 +12,8 @@
   :depends-on (#:alexandria
                #:esrap
                #:plump
-               #:clss)
+               #:clss
+               #:com.inuoe.jzon)
   :components ((:file "chronogram-cldr-parser")))
 
 (asdf:defsystem #:chronogram/test