|
| 1 | +;;;; json2ecl.lisp |
| 2 | +;;;; |
| 3 | +;;;; See https://github.com/Zulu-Inuoe/jzon |
| 4 | + |
| 5 | +(in-package #:json2ecl) |
| 6 | + |
| 7 | +;;; |
| 8 | + |
| 9 | +(defvar *layout-names* nil) |
| 10 | + |
| 11 | +;;; |
| 12 | + |
| 13 | +(defclass array-item () |
| 14 | + ((object-prototype :accessor object-prototype :initform nil) |
| 15 | + (element-type :accessor element-type :initform nil))) |
| 16 | + |
| 17 | +(defclass object-item () |
| 18 | + ((keys :accessor keys :initform (make-hash-table :test 'equalp :size 25)))) |
| 19 | + |
| 20 | +;;; |
| 21 | + |
| 22 | +(defmethod pp ((obj t) &optional (depth 0)) |
| 23 | + (declare (ignore depth)) |
| 24 | + (with-output-to-string (s) |
| 25 | + (format s "~A~%" obj))) |
| 26 | + |
| 27 | +(defmethod pp ((obj array-item) &optional (depth 0)) |
| 28 | + (with-output-to-string (s) |
| 29 | + (format s "[~%") |
| 30 | + (format s "~vT~A" (* (1+ depth) 4) (pp (or (object-prototype obj) (element-type obj)) (1+ depth))) |
| 31 | + (format s "~vT]~%" (* depth 4)))) |
| 32 | + |
| 33 | +(defmethod pp ((obj object-item) &optional (depth 0)) |
| 34 | + (with-output-to-string (s) |
| 35 | + (format s "{~%") |
| 36 | + (loop for key being the hash-keys of (keys obj) |
| 37 | + using (hash-value value) |
| 38 | + do (format s "~vT~A: ~A" (* (1+ depth) 4) key (pp value (1+ depth)))) |
| 39 | + (format s "~vT}~%" (* depth 4)))) |
| 40 | + |
| 41 | +;;; |
| 42 | + |
| 43 | +(defun ecl-keyword-p (name) |
| 44 | + (member name *ecl-keywords* :test 'equalp)) |
| 45 | + |
| 46 | +(defun ecl-name (name) |
| 47 | + (let* ((lowername (string-downcase name)) |
| 48 | + (no-dashes (substitute #\_ #\- lowername)) |
| 49 | + (legal (if (or (not (alpha-char-p (elt no-dashes 0))) |
| 50 | + (ecl-keyword-p no-dashes)) |
| 51 | + (format nil "f_~A" no-dashes) |
| 52 | + no-dashes))) |
| 53 | + legal)) |
| 54 | + |
| 55 | +(defun layout-name (name) |
| 56 | + (let* ((legal-name (string-upcase (substitute #\_ #\- name))) |
| 57 | + (name-count (count-if #'(lambda (x) (equalp x legal-name)) *layout-names*)) |
| 58 | + (interstitial (if (zerop name-count) "" (format nil "_~3,'0D" name-count)))) |
| 59 | + (push legal-name *layout-names*) |
| 60 | + (format nil "~A~A_LAYOUT" legal-name interstitial))) |
| 61 | + |
| 62 | +(defun ecl-xpath (name) |
| 63 | + (format nil "{XPATH('~A')}" name)) |
| 64 | + |
| 65 | +(defun ecl-type (value-type) |
| 66 | + (case value-type |
| 67 | + (boolean "BOOLEAN") |
| 68 | + (symbol "STRING") |
| 69 | + (string "STRING") |
| 70 | + (utf8 "UTF8") |
| 71 | + (number "INTEGER"))) |
| 72 | + |
| 73 | +(defun dataset-datatype-name (name) |
| 74 | + (format nil "DATASET(~A)" (layout-name name))) |
| 75 | + |
| 76 | +;;; |
| 77 | + |
| 78 | +(defmethod as-ecl-fielddef ((value-obj t) name) |
| 79 | + (let ((ecl-type (ecl-type value-obj))) |
| 80 | + (format nil "~4T~A ~A ~A;~%" ecl-type (ecl-name name) (ecl-xpath name)))) |
| 81 | + |
| 82 | +(defmethod as-ecl-fielddef ((obj object-item) name) |
| 83 | + (format nil "~4T~A ~A ~A;~%" (dataset-datatype-name name) (ecl-name name) (ecl-xpath name))) |
| 84 | + |
| 85 | +(defmethod as-ecl-fielddef ((obj array-item) name) |
| 86 | + (if (element-type obj) |
| 87 | + (format nil "~4TSET OF ~A ~A ~A;~%" (ecl-type (element-type obj)) (ecl-name name) (ecl-xpath name)) |
| 88 | + (format nil "~4T~A ~A ~A;~%" (dataset-datatype-name name) (ecl-name name) (ecl-xpath name)))) |
| 89 | + |
| 90 | +;;; |
| 91 | + |
| 92 | +(defmethod as-ecl-recdef ((obj t) name) |
| 93 | + (declare (ignore obj name)) |
| 94 | + "") |
| 95 | + |
| 96 | +(defmethod as-ecl-recdef ((obj object-item) name) |
| 97 | + (let* ((result-str "") |
| 98 | + (my-str (with-output-to-string (s) |
| 99 | + (format s "~A := RECORD~%" (layout-name name)) |
| 100 | + (loop for field-name being the hash-keys of (keys obj) |
| 101 | + using (hash-value field-value) |
| 102 | + do (let ((child-recdef (as-ecl-recdef field-value field-name))) |
| 103 | + (when (string/= child-recdef "") |
| 104 | + (setf result-str (format nil "~A~A" result-str child-recdef))) |
| 105 | + (format s "~A" (as-ecl-fielddef field-value field-name)))) |
| 106 | + (format s "END;~%~%")))) |
| 107 | + (format nil "~A~A" result-str my-str))) |
| 108 | + |
| 109 | +(defmethod as-ecl-recdef ((obj array-item) name) |
| 110 | + (if (object-prototype obj) |
| 111 | + (as-ecl-recdef (object-prototype obj) name) |
| 112 | + "")) |
| 113 | + |
| 114 | +;;; |
| 115 | + |
| 116 | +(defmacro reuse-object (place classname) |
| 117 | + `(progn |
| 118 | + (cond ((null ,place) |
| 119 | + (setf ,place (make-instance ,classname))) |
| 120 | + ((not (typep ,place ,classname)) |
| 121 | + (error "Mismatching object types"))) |
| 122 | + ,place)) |
| 123 | + |
| 124 | +(defmacro parse-simple (place value) |
| 125 | + `(setf ,place (common-type (base-type ,value) ,place))) |
| 126 | + |
| 127 | +(defmacro parse-complex (place classname parser) |
| 128 | + `(progn |
| 129 | + (reuse-object ,place ,classname) |
| 130 | + (parse-obj ,place ,parser))) |
| 131 | + |
| 132 | +;;; |
| 133 | + |
| 134 | +(defun base-type (thing) |
| 135 | + (etypecase thing |
| 136 | + ((eql t) 'boolean) |
| 137 | + ((eql nil) 'boolean) |
| 138 | + ((eql null) 'symbol) |
| 139 | + (integer 'number) |
| 140 | + (double-float 'number) |
| 141 | + (string 'utf8))) |
| 142 | + |
| 143 | +(defun common-type (new-type old-type) |
| 144 | + (cond ((not old-type) new-type) |
| 145 | + ((or (eql old-type 'utf8) (eql new-type 'utf8)) 'utf8) |
| 146 | + ((not (eql old-type new-type)) 'string) |
| 147 | + (t new-type))) |
| 148 | + |
| 149 | +;;; |
| 150 | + |
| 151 | +(defmethod parse-obj ((obj array-item) parser) |
| 152 | + (loop named parse |
| 153 | + do (multiple-value-bind (event value) (jzon:parse-next parser) |
| 154 | + (cond ((null event) |
| 155 | + (error "Unexpected end of file")) |
| 156 | + ((eql event :end-array) |
| 157 | + (return-from parse)) |
| 158 | + ((eql event :value) |
| 159 | + (parse-simple(element-type obj) value)) |
| 160 | + ((eql event :begin-array) |
| 161 | + (parse-complex (object-prototype obj) 'array-item parser)) |
| 162 | + ((eql event :begin-object) |
| 163 | + (parse-complex (object-prototype obj) 'object-item parser)) |
| 164 | + (t |
| 165 | + (error "Unknown object while parsing array: (~A,~A)" event value))))) |
| 166 | + obj) |
| 167 | + |
| 168 | +(defmethod parse-obj ((obj object-item) parser) |
| 169 | + (loop named parse |
| 170 | + do (multiple-value-bind (event value) (jzon:parse-next parser) |
| 171 | + (cond ((null event) |
| 172 | + (error "Unexpected end of file")) |
| 173 | + ((eql event :end-object) |
| 174 | + (return-from parse)) |
| 175 | + ((eql event :object-key) |
| 176 | + (multiple-value-bind (key-event key-value) (jzon:parse-next parser) |
| 177 | + (case key-event |
| 178 | + ((:value) |
| 179 | + (parse-simple (gethash value (keys obj)) key-value)) |
| 180 | + ((:begin-array) |
| 181 | + (parse-complex (gethash value (keys obj)) 'array-item parser)) |
| 182 | + ((:begin-object) |
| 183 | + (parse-complex (gethash value (keys obj)) 'object-item parser)) |
| 184 | + (otherwise |
| 185 | + (error "Unknown object while parsing object value: (~A,~A)" key-event key-value))))) |
| 186 | + (t |
| 187 | + (error "Unknown object while parsing object: (~A,~A)" event value))))) |
| 188 | + obj) |
| 189 | + |
| 190 | +(defmethod parse-obj ((obj t) parser) |
| 191 | + (declare (ignore obj)) |
| 192 | + (let ((top-object nil)) |
| 193 | + (loop named parse |
| 194 | + do (multiple-value-bind (event value) (jzon:parse-next parser) |
| 195 | + (cond ((null event) |
| 196 | + (return-from parse)) |
| 197 | + ((eql event :begin-array) |
| 198 | + (reuse-object top-object 'array-item) |
| 199 | + (parse-obj top-object parser)) |
| 200 | + ((eql event :begin-object) |
| 201 | + (reuse-object top-object 'object-item) |
| 202 | + (parse-obj top-object parser)) |
| 203 | + (t |
| 204 | + (error "Unknown object at toplevel: (~A,~A)" event value))))) |
| 205 | + top-object)) |
| 206 | + |
| 207 | +;;; |
| 208 | + |
| 209 | +(defun process-file (input) |
| 210 | + (let ((parsed-obj nil)) |
| 211 | + (setf *layout-names* nil) |
| 212 | + (jzon:with-parser (parser input) |
| 213 | + (setf parsed-obj (parse-obj nil parser))) |
| 214 | + parsed-obj)) |
0 commit comments