-
-
Notifications
You must be signed in to change notification settings - Fork 29
/
serialization.lisp
146 lines (124 loc) · 6.56 KB
/
serialization.lisp
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
(in-package #:org.shirakumo.fraf.kandria)
(defclass version () ())
(define-condition serializer-error ()
((version :initarg :version :reader version)))
(define-condition no-applicable-decoder (serializer-error)
((target :initarg :target :reader target))
(:report (lambda (c s) (format s "No decoder for the target under ~a~% ~a"
(version c) (target c)))))
(define-condition no-applicable-encoder (serializer-error)
((source :initarg :source :reader source))
(:report (lambda (c s) (format s "No encoder for the source under ~a~% ~a"
(version c) (source c)))))
(defun current-version ()
;; KLUDGE: latest version should be determined automatically.
(make-instance 'world-v0))
(defun coerce-version (symbol)
(flet ((bail () (error "No such version ~s." symbol)))
(if (typep symbol 'version)
symbol
(let* ((class (or (find-class symbol NIL) (bail))))
(unless (subtypep class 'version) (bail))
(make-instance class)))))
(defun ensure-version (version &optional (default (current-version)))
(etypecase version
(version version)
((eql T) default)
(symbol (coerce-version version))))
(defmethod supported-p ((version version)) NIL)
(defgeneric decode-payload (payload target depot version))
(defgeneric encode-payload (source payload depot version))
(defmethod decode-payload (payload target depot (version version))
(error 'no-applicable-decoder :target target :version version))
(defmethod encode-payload (source payload depot (version version))
(error 'no-applicable-encoder :source source :version version))
(defmethod decode-payload (payload (target symbol) depot version)
(if (eql target 'symbol)
(call-next-method)
(decode-payload payload (type-prototype target) depot version)))
(defmethod decode-payload (payload target depot (version symbol))
(decode-payload payload target depot (ensure-version version)))
(defmethod encode-payload (source payload depot (version symbol))
(encode-payload source payload depot (ensure-version version)))
(defmacro define-encoder ((type version) &rest args)
(let ((object (gensym "OBJECT"))
(method-combination (loop for option = (car args)
until (listp option)
collect (pop args))))
(destructuring-bind (version-instance version) (enlist version version)
(destructuring-bind ((buffer depot) &rest body) args
(let ((buffer-name (unlist buffer)))
`(defmethod encode-payload ,@method-combination ((,type ,type) ,buffer ,depot (,version-instance ,version))
(flet ((encode (,object &optional (,buffer-name ,buffer-name))
(encode-payload ,object
,buffer-name
,(unlist depot)
,version-instance)))
(declare (ignorable #'encode))
,@body)))))))
#++
(defmethod encode-payload :before ((type entity) buffer depot version)
(v:trace :kandria.serializer "Encoding ~a" type))
(trivial-indent:define-indentation define-encoder (4 4 &body))
(defmacro define-decoder ((type version) &rest args)
(let ((object (gensym "OBJECT"))
(method-combination (loop for option = (car args)
until (listp option)
collect (pop args))))
(destructuring-bind (version-instance version) (enlist version version)
(destructuring-bind ((buffer depot) &rest body) args
(let ((buffer-name (unlist buffer)))
`(defmethod decode-payload ,@method-combination (,buffer (,type ,type) ,depot (,version-instance ,version))
(flet ((decode (,object &optional (,buffer-name ,buffer-name))
(decode-payload ,buffer-name
(if (symbolp ,object)
(type-prototype ,object)
,object)
,(unlist depot)
,version-instance)))
(declare (ignorable #'decode))
,@body)))))))
(trivial-indent:define-indentation define-decoder (4 4 &body))
(defun translate-slot-spec (spec)
(destructuring-bind (name &key (reader name) (type T) (initarg (kw name)) (default NIL)) (enlist spec)
(list reader name type initarg default)))
(defmacro define-slot-coders ((type version) slots)
(let ((slots (mapcar #'translate-slot-spec slots)))
`(progn
(define-encoder (,type ,version) (_b _p)
(list (type-of ,type)
,@(loop for (reader name slot-type kw) in slots
collect kw
collect (if (eql slot-type T)
`(,reader ,type)
`(encode (,reader ,type))))))
(define-decoder (,type ,version) (initargs _)
(destructuring-bind (&key ,@(loop for (reader name type kw default) in slots
collect `((,kw ,name) ,default)) &allow-other-keys) initargs
(make-instance (class-of ,type)
,@(loop for (reader name slot-type kw) in slots
collect kw
collect (if (eql slot-type T)
name
`(decode ',slot-type ,name)))))))))
(defmacro define-additional-slot-coders ((type version) slots)
(let ((slots (mapcar #'translate-slot-spec slots)))
`(progn
(define-encoder (,type ,version) (_b _p)
(nconc (call-next-method)
(list
,@(loop for (reader name slot-type kw) in slots
collect kw
collect (if (eql slot-type T)
`(,reader ,type)
`(encode (,reader ,type)))))))
(define-decoder (,type ,version) (initargs _)
(let ((,type (call-next-method)))
(destructuring-bind (&key ,@(loop for (reader name type kw default) in slots
collect `((,kw ,name) ,default)) &allow-other-keys) initargs
,@(loop for (reader name slot-type kw) in slots
collect `(setf (slot-value ,type ',name)
,(if (eql slot-type T)
name
`(decode ',slot-type ,name))))
,type))))))