git.fiddlerwoaroof.com
Browse code

Parser enhancements, adding converters for tagged objects and handling quoted scalar values.

Jason Melbye authored on 20/08/2016 02:03:43
Showing 2 changed files
src/parser.lisp
History View file @ 23d3a77
... ... 
@@ -6,10 +6,44 @@
6 6 
   (:import-from :libyaml.macros
7 7 
                 :with-parser
8 8 
                 :with-event)
9 
-  (:export :parse-string)
9 
+  (:export :parse-string
10 
+	   :register-scalar-converter
11 
+	   :register-sequence-converter
12 
+	   :register-mapping-converter)
10 13 
   (:documentation "The YAML parser."))
11 14 
 (in-package :yaml.parser)
12 15
16 
+(defvar +scalar-converters+ (make-hash-table :test #'equalp))
17 
+(defvar +sequence-converters+ (make-hash-table :test #'equalp))
18 
+(defvar +mapping-converters+ (make-hash-table :test #'equalp))
19 
+
20 
+(defun scalar-converter (tag)
21 
+  (gethash tag +scalar-converters+))
22 
+
23 
+(defun convert-scalar (string tag &optional (style :plain-scalar-stype))
24 
+  (let ((converter (scalar-converter tag)))
25 
+    (if converter
26 
+	(funcall converter string)
27 
+	(yaml.scalar:parse-scalar string style))))
28 
+
29 
+(defun sequence-converter (tag)
30 
+  (gethash tag +sequence-converters+))
31 
+
32 
+(defun convert-sequence (list tag)
33 
+  (let ((converter (sequence-converter tag)))
34 
+    (if converter
35 
+	(funcall converter list)
36 
+	list)))
37 
+
38 
+(defun mapping-converter (tag)
39 
+  (gethash tag +mapping-converters+))
40 
+
41 
+(defun convert-mapping (hashtable tag)
42 
+  (let ((converter (mapping-converter tag)))
43 
+    (if converter
44 
+	(funcall converter hashtable)
45 
+	hashtable)))
46 
+
13 47 
 ;;; The parser
14 48
15 49 
 (defun signal-reader-error (parser)
... ... 
@@ -94,31 +128,32 @@
94 128 
          t)
95 129 
         |#
96 130 
         ;; Scalar
97 
-        ((:scalar-event &key anchor tag value)
98 
-         (declare (ignore anchor tag))
131 
+        ((:scalar-event &key anchor tag value length plain-implicit quoted-implicit style)
132 
+         (declare (ignore anchor length plain-implicit quoted-implicit))
99 133 
          (setf (first contexts)
100 134 
                (append (first contexts)
101 
-                       (list (yaml.scalar:parse-scalar value)))))
135 
+                       (list (convert-scalar value tag style)))))
102 136 
         ;; Sequence start event
103 
-        ((:sequence-start-event &key anchor tag)
104 
-         (declare (ignore anchor tag))
105 
-         (push (list) contexts))
137 
+        ((:sequence-start-event &key anchor tag implicit style)
138 
+         (declare (ignore anchor implicit style))
139 
+         (push (list tag) contexts))
106 140 
         ;; Mapping start event
107 
-        ((:mapping-start-event &key anchor tag)
108 
-         (declare (ignore anchor tag))
109 
-         (push (list) contexts))
141 
+        ((:mapping-start-event &key anchor tag implicit style)
142 
+         (declare (ignore anchor implicit style))
143 
+         (push (list tag) contexts))
110 144 
         ;; End events
111 145 
         ((:sequence-end-event)
112 
-         (let ((con (pop contexts)))
146 
+         (destructuring-bind (tag &rest seq) (pop contexts)
113 147 
            (setf (first contexts)
114 148 
                  (append (first contexts)
115 
-                         (list con)))))
149 
+                         (list (convert-sequence seq tag))))))
116 150 
         ((:mapping-end-event)
117 
-         (let ((con (pop contexts)))
151 
+         (destructuring-bind (tag &rest plist) (pop contexts)
118 152 
            (setf (first contexts)
119 153 
                  (append (first contexts)
120 
-                         (list
121 
-                          (alexandria:plist-hash-table con :test #'equal))))))
154 
+                         (list (convert-mapping
155 
+				(alexandria:plist-hash-table plist :test #'equalp)
156 
+				tag))))))
122 157 
         ;; Do nothing
123 158 
         ((t &rest rest)
124 159 
          (declare (ignore rest)))))
... ... 
@@ -126,5 +161,14 @@
126 161
127 162 
 ;;; The public interface
128 163
164 
+(defun register-scalar-converter (tag converter)
165 
+  (setf (gethash tag +scalar-converters+) converter))
166 
+
167 
+(defun register-sequence-converter (tag converter)
168 
+  (setf (gethash tag +sequence-converters+) converter))
169 
+
170 
+(defun register-mapping-converter (tag converter)
171 
+  (setf (gethash tag +mapping-converters+) converter))
172 
+
129 173 
 (defun parse-string (yaml-string)
130 174 
   (parse-tokens (parse-yaml yaml-string)))
src/scalar.lisp
History View file @ 23d3a77
... ... 
@@ -15,6 +15,9 @@
15 15
16 16 
 ;;; Regular expressions or lists of names
17 17
18 
+(defparameter +quoted-scalar-styles+
19 
+  (list :single-quoted-scalar-style :double-quoted-scalar-style))
20 
+
18 21 
 (defparameter +null-names+
19 22 
   (list "null" "Null" "NULL" "~"))
20 23
... ... 
@@ -48,9 +51,12 @@
48 51
49 52 
 ;;; The actual parser
50 53
51 
-(defun parse-scalar (string)
54 
+(defun parse-scalar (string &optional (style :plain-scalar-style))
52 55 
   "Parse a YAML scalar string into a Lisp scalar value."
53 56 
   (cond
57 
+    ;; Quoted string
58 
+    ((member style +quoted-scalar-styles+)
59 
+     string)
54 60 
     ;; Null
55 61 
     ((member string +null-names+ :test #'equal)
56 62 
      +null+)