cl-yaclyaml/representing.lisp at master · mabragor/cl-yaclyaml · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
;;;; This file is one of components of CL-YACLYAML system, licenced under GPL, see COPYING for details

(in-package #:cl-yaclyaml)

;;; Representing native structures as sequences, mappings and scalars with tags.

(defparameter tag-prefix "tag:yaml.org,2002:")

(defparameter lisp-tag-prefix "tag:lisp,2013:")

(defparameter cons-maps-as-maps nil "If T, represent alists and plists as mappings, not as sequences")

(defun represent-scalar (x)
  (flet ((frob (type obj &optional (prefix tag-prefix))
	   ;; FIXME: maybe FORMAT-aesthetic on the next line is not what we really want?
	   (values `((:properties . ((:tag . ,(strcat prefix type)))) (:content . ,(format nil "~a" obj))) t)))
    (typecase x
      (integer (frob "int" x))
      (float (frob "float" x))
      (string (frob "str" x))
      (symbol (cond ((eq x t) (frob "bool" "true"))
		    ((eq x nil) (frob "null" "null"))
		    ((keywordp x) (frob "keyword" x lisp-tag-prefix))
		    (t (frob "symbol" x lisp-tag-prefix))))
      (t (values nil nil)))))

(defun represent-mapping (x)
  (declare (special representation-cache))
  (declare (special visited-cache))
  (declare (special initialization-callbacks))
  (let (result last-cons)
    (macrolet ((collect-result (o!-key o!-val)
		 (once-only (o!-key o!-val)
		   `(if result
			(progn (setf (cdr last-cons) (list `(,,o!-key . ,,o!-val)))
			       (setf last-cons (cdr last-cons)))
			(progn (setf result (list `(,,o!-key . ,,o!-val)))
			       (setf last-cons result)))))
	       (frob ()
		 `(progn
		    (if (gethash key visited-cache)
			(if (gethash val visited-cache)
			    (progn (collect-result nil nil)
				   (let (initialized-key
					 initialized-val
					 (encap-key key)
					 (encap-val val)
					 (encap-last-cons last-cons))
				     (flet ((frob-key ()
					      (if initialized-val
						  (setf (caar encap-last-cons) initialized-key
							(cdar encap-last-cons) initialized-val)
						  (setf initialized-key (gethash encap-key representation-cache))))
					    (frob-val ()
					      (if initialized-key
						  (setf (caar encap-last-cons) initialized-key
							(cdar encap-last-cons) initialized-val)
						  (setf initialized-val (gethash encap-val representation-cache)))))
				       (push #'frob-key (gethash key initialization-callbacks))
				       (push #'frob-val (gethash val initialization-callbacks)))))
			    (progn (collect-result nil (%represent-node val))
				   (push (let ((encap-key key)
					       (encap-last-cons last-cons))
					   (lambda ()
					     (setf (caar encap-last-cons)
						   (gethash encap-key representation-cache))))
					 (gethash key initialization-callbacks))))
			(if (gethash val visited-cache)
			    (progn (collect-result (%represent-node key) nil)
				   (push (let ((encap-val val)
					       (encap-last-cons last-cons))
					   (lambda ()
					     (setf (cdar encap-last-cons)
						   (gethash encap-val representation-cache))))
					 (gethash val initialization-callbacks)))
			    (collect-result (%represent-node key) (%represent-node  val))))
		    (collect `(,(%represent-node key) . ,(%represent-node val)) into res)
		    (finally (return (values `((:properties . ((:tag . ,(strcat tag-prefix "map"))))
					       (:content . (:mapping ,.result)))
					     t))))))
      (typecase x
	(hash-table (if (eq (hash-table-test x) 'equal)
			(iter (for (key val) in-hashtable x)
			      (frob))
			(error "Hash-tables with test-functions other than EQUAL cannot be dumped now.")))
	(cons (cond ((and cons-maps-as-maps (alist-p x))
		     (iter (for (key . val) in x)
			   (frob)))
		    ((and cons-maps-as-maps (plist-p x))
		     (iter (for key in x by #'cddr)
			   (for val in (cdr x) by #'cddr)
			   (frob)))
		    (t (values nil nil))))
	(t (values nil nil))))))

(defun represent-sequence (x)
  (declare (special representation-cache))
  (declare (special visited-cache))
  (declare (special initialization-callbacks))
  (let (result last-cons)
    (macrolet ((collect-result (o!-node)
		 (once-only (o!-node)
		   `(if result
			(progn (setf (cdr last-cons) (list ,o!-node))
			       (setf last-cons (cdr last-cons)))
			(progn (setf result (list ,o!-node))
			       (setf last-cons result)))))
	       (frob ()
		 `(progn (if (gethash subnode visited-cache)
			     (progn (collect-result nil)
				    (push (let ((encap-subnode subnode)
						(encap-last-cons last-cons))
					    (lambda ()
					      (setf (car encap-last-cons)
						    (gethash encap-subnode representation-cache))))
					  (gethash subnode initialization-callbacks)))
			     (collect-result (%represent-node subnode)))
			 (finally (return (values `((:properties . ((:tag . ,(strcat tag-prefix "seq"))))
						    (:content . ,result))
						  t))))))
      (typecase x
	(cons (iter (for subnode in x)
		    (frob)))
	((and array (not string)) (iter (for subnode in-vector x)
					(frob)))
	(t (values nil nil))))))

(defun %represent-node (x)
  (declare (special representation-cache))
  (declare (special initialization-callbacks))
  (declare (special visited-cache))
  (setf (gethash x visited-cache) t)
  (multiple-value-bind (it got) (gethash x representation-cache)
    (if got
	it
	(let ((res (multiple-value-bind (it got) (represent-mapping x)
		     (if got
			 it
			 (multiple-value-bind (it got) (represent-sequence x)
			   (if got
			       it
			       (multiple-value-bind (it got) (represent-scalar x)
				 (if got
				     it
				     (error "Failed to represent object: ~a" x)))))))))
	  (setf (gethash x representation-cache) res)
	  (iter (for callback in (gethash x initialization-callbacks))
		(funcall callback))
	  (remhash x initialization-callbacks)
	  res))))

(defun represent-node (x)
  (let ((representation-cache (make-hash-table :test #'eq))
	(visited-cache (make-hash-table :test #'eq))
	(initialization-callbacks (make-hash-table :test #'eq)))
    (declare (special representation-cache))
    (declare (special visited-cache))
    (declare (special initialization-callbacks))
    (%represent-node x)))

(defun plist-p (x)
  (declare (ignorable x))
  "Returns T if X is a property list in a narrow sense - all odd elements are non-duplicating symbols."
  nil)

(defun alist-p (x)
  (declare (ignorable x))
  "Returns T if X is an association list in a narrow sense - all CAR's of assocs are non-duplicating symbols."
  nil)