New 3rd-party dependency: cl-yaml

cl_yaml/CMakeLists.txt

@@ -0,0 +1,5 @@
+cmake_minimum_required(VERSION 2.8.3)
+project(cl_yaml)
+
+find_package(catkin REQUIRED)
+catkin_package()

cl_yaml/README.md

@@ -0,0 +1,30 @@
+`cl-yaml` is a [libyaml](http://pyyaml.org/wiki/LibYAML)-based YAML parser for Common Lisp.
+
+# Usage
+
+```lisp
+CL-YAML> (yaml:parse #p"network/hosts.yaml")
+{"prod" => ("something.herokuapp.com" 6767), "db" => ("somewhere.org" 5432)}
+CL-YAML> (yaml:parse "{arch: x86-64, cc: clang, user: eudoxia}")
+{"arch" => "x86-64", "cc" => "clang", "user" => "eudoxia"}
+CL-USER> (yaml:emit (list "foo" "bar"))
+"[\"foo\", \"bar\"]"
+CL-USER> (yaml:emit '((a 1) (b 2) (c 3)))
+"[[A, 1], [B, 2], [C, 3]]"
+```
+
+[Hash table syntax](http://frank.kank.net/essays/hash.html) is used in the examples. I recommend at least using its hash table printer because the default is basically useless.
+
+# Installation
+
+You need `libyaml` for this to work.
+
+# License
+
+Copyright (C) 2013 Fernando Borretti
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

cl_yaml/cl-yaml-test.asd

@@ -0,0 +1,11 @@
+(defsystem cl-yaml-test
+  :author "Fernando Borretti"
+  :license "MIT"
+  :depends-on (:cl-yaml
+               :fiveam)
+  :components ((:module "test"
+                :serial t
+                :components
+                ((:file "cl-yaml")
+		 (:file "bench"))))
+  :perform (load-op :after (op c) (asdf:clear-system c)))

cl_yaml/cl-yaml.asd

@@ -0,0 +1,76 @@
+(in-package :cl-user)
+(defpackage cl-yaml-asd
+  (:use :cl :asdf))
+(in-package :cl-yaml-asd)
+
+(defclass c->so (source-file) ())
+
+(defmethod source-file-type ((c c->so) (s module)) "c")
+
+(defmethod output-files ((operation compile-op) (f c->so))
+  (values
+    (list
+      (make-pathname :name "yaml_wrapper"
+                     :type #+unix "so" #+darwin "dylib" #+windows "dll"
+                     :defaults
+                     (merge-pathnames
+                      (make-pathname :directory '(:relative :up))
+                      (component-pathname f)))) t))
+
+(defmethod perform ((o load-op) (c c->so)) t)
+
+(defparameter +c-flags+ "-Wall -Wextra -c -fPIC -O0 -g")
+(defparameter +linker-flags+ "-lyaml")
+
+(defun comp (file out)
+  (format t "cc ~A -o out.o ~A && cc out.o -shared -o ~A ~A && rm out.o"
+          (namestring file) +c-flags+ (namestring out) +linker-flags+)
+  (format nil "cc ~A -o out.o ~A && cc out.o -shared -o ~A ~A && rm out.o"
+          (namestring file) +c-flags+ (namestring out) +linker-flags+))
+
+(defmethod perform ((o compile-op) (c c->so))
+  (if (not (zerop (run-shell-command
+                   (comp (make-pathname :name "yaml"
+                                        :type "c"
+                                        :defaults
+                                        (merge-pathnames
+                                         "src"
+                                         (component-pathname c)))
+                         (make-pathname :name "yaml_wrapper"
+                                        :type "so"
+                                        :defaults
+                                        (merge-pathnames
+                                         (make-pathname :directory '(:relative :up))
+                                         (component-pathname c)))))))
+      (error 'operation-error :component c :operation o)
+      t))
+
+(defsystem cl-yaml
+  :version "0.2"
+  :author "Fernando Borretti"
+  :license "MIT"
+  :depends-on (:cffi
+               :split-sequence)
+  :serial t
+  :components ((:module "src"
+                :serial t
+                :components
+                ((:static-file "yaml.h")
+                 (c->so "yaml" :depends-on ("yaml.h"))
+                 (:file "ffi")
+                 (:file "cl-yaml")))
+               (:module "spec"))
+  :description ""
+  :long-description
+  #.(with-open-file (stream (merge-pathnames
+                             #p"README.md"
+                             (or *load-pathname* *compile-file-pathname*))
+                            :if-does-not-exist nil
+                            :direction :input)
+      (when stream
+        (let ((seq (make-array (file-length stream)
+                               :element-type 'character
+                               :fill-pointer t)))
+          (setf (fill-pointer seq) (read-sequence seq stream))
+          seq)))
+  :in-order-to ((test-op (load-op cl-yaml-test))))

cl_yaml/package.xml

@@ -0,0 +1,27 @@
+<package>
+  <name>cl_yaml</name>
+  <version>0.2.0</version>
+  <description>
+    3rd party library: A common lisp wrapper around libyaml,
+    a C yaml parser/emitter for yaml 1.1.
+  </description>
+
+  <maintainer email="georg.bartels@cs.uni-bremen.de">Georg Bartels</maintainer>
+  <author email="eudoxiahp@gmail.com">Fernando Borretti</author>
+
+  <license>MIT</license>
+
+  <url type="repository">https://github.com/cram-code/cram_3rdparty</url>
+  <url type="repository">https://github.com/eudoxia0/cl-yaml</url>
+
+  <buildtool_depend>catkin</buildtool_depend>
+
+  <build_depend>libyaml</build_depend>
+  <build_depend>cffi</build_depend>
+  <build_depend>split_sequence</build_depend>
+  <build_depend>sbcl</build_depend>
+  <run_depend>sbcl</run_depend>
+  <run_depend>split_sequence</run_depend>
+  <run_depend>cffi</run_depend>
+  <run_depend>libyaml</run_depend>
+</package>

cl_yaml/src/cl-yaml.lisp

@@ -0,0 +1,143 @@
+(defpackage :yaml
+  (:use :cl :split-sequence :libyaml)
+  (:import-from :cffi
+                :with-foreign-string
+                :foreign-string-to-lisp)
+  (:export :parse
+           :emit))
+(in-package :yaml)
+
+(defun clean (tokens)
+  "I am not a clever man."
+  (remove-if
+   #'(lambda (tok)
+       (or (eq (first tok) :stream-start)
+           (eq (first tok) :stream-end)))
+   tokens))
+
+(defparameter *delimiters*
+  (list :seq-start :seq-end :map-start :map-end
+        :stream-start :stream-end :doc-start :doc-end))
+
+(defun group-documents (tokens)
+  (remove-if #'(lambda (seq)
+                 (or (eql (length seq) 0)
+                     (and (eql (length seq) 1)
+                          (member (first (elt seq 0))
+                                  *delimiters*))))
+             (split-sequence-if
+              #'(lambda (tok)
+                  (or (eq (first tok) :doc-start)
+                      (eq (first tok) :doc-end)))
+              tokens)))
+
+(defun process (str &optional (len (length str)))
+  (let ((tok-list (tokenize str len))
+        (tokens (make-array 64 :fill-pointer 0 :adjustable t)))
+    (if (list-err tok-list)
+        (error "Parsing error")
+        (progn
+          (loop for i from 0 to (list-len tok-list) do
+            (let* ((tok (nth-tok tok-list i))
+                   (type (gethash (tok-type tok) +enum+)))
+              (if type
+                  (progn
+                    (vector-push-extend (list type
+                                              (tok-value tok)
+                                              (tok-anchor tok))
+                                        tokens)
+                    (destroy-nth-tok tok-list i)))))
+          (destroy-token-list tok-list)
+          (group-documents (clean tokens))))))
+
+(defmacro with-preserved-case (&rest code)
+  `(unwind-protect
+     (progn
+       (setf (readtable-case *readtable*) :preserve)
+       ,@code)
+     (setf (readtable-case *readtable*) :upcase)))
+
+(defun extract-type (val)
+  (handler-case
+    (let ((res
+	   (if (position #\Space val)
+	       val
+	       (with-preserved-case
+	         (read-from-string val)))))
+      (if (symbolp res)
+	  (symbol-name res)
+	  res))
+    (error () val)))
+
+(defun parse% (documents)
+  (loop for tokens in documents collecting
+    (let ((contexts (list nil))
+          (aliases  (make-hash-table :test #'equal)))
+      (loop for tok across tokens do
+        (let ((type   (first tok))
+              (val    (second tok))
+              (anchor (third tok)))
+	  (cond
+	    ((eq type :seq-start)
+	     (push (list) contexts))
+	    ((eq type :seq-end)
+	     (let ((con (pop contexts)))
+	       (setf (first contexts) (append (first contexts) (list con)))))
+	    ((eq type :map-start)
+	     (push (list) contexts))
+	    ((eq type :map-end)
+	     (let ((con (pop contexts)))
+	       (setf (first contexts)
+                     (append (first contexts)
+                             (list
+                              (alexandria:plist-hash-table con :test #'equal))))))
+            ((eq type :alias)
+             (setf (gethash val aliases) (first contexts)))
+            (anchor
+             (setf (first contexts)
+                   (append (first contexts)
+                           (list (gethash val aliases)))))
+	    (t
+	     (setf (first contexts)
+                   (append (first contexts)
+                           (list (extract-type val))))))))
+             (caar contexts))))
+
+(defun post-process (documents)
+  (if (cdr documents)
+      (mapcar #'(lambda (doc) (list :doc doc)) documents)
+      (car documents)))
+
+(defun slurp-stream (stream)
+  (let ((seq (make-string (file-length stream))))
+    (read-sequence seq stream)
+    seq))
+
+(defun parse (src)
+  (typecase src
+    (string
+     (post-process (parse% (process src (length src)))))
+    (pathname
+     (let ((str (with-open-file
+                    (stream src :direction :input :if-does-not-exist :error)
+                  (slurp-stream stream))))
+       (post-process
+        (parse%
+         (process str (length str))))))
+    (t
+      (error "Unknown input to yaml:load."))))
+
+(defun emit (obj)
+  (typecase obj
+    (number
+      (princ-to-string obj))
+    (string
+      (format nil "~S" obj))
+    (symbol
+      (format nil "~A" obj))
+    (list
+      (format nil "[~{~A~#[~:;, ~]~}]" (mapcar #'emit obj)))
+    (hash-table
+     (format nil "{~{~A~#[~:;, ~]~}}"
+	     (loop for key being the hash-keys of obj collecting
+		  (format nil "~A : ~A" key (gethash key obj)))))))

cl_yaml/src/ffi.lisp

@@ -0,0 +1,81 @@
+(defpackage :libyaml
+  (:use :cl :cffi)
+  (:export :tokenize
+           :list-len
+           :list-err
+           :nth-tok
+           :destroy-nth-tok
+           :tok-type
+           :tok-value
+           :tok-anchor
+           :destroy-token-list
+           :+enum+
+           :+scalar+
+           :+alias+
+           :+seq-start+
+           :+seq-end+
+           :+map-start+
+           :+map-end+
+           :+doc-start+
+           :+doc-end+
+           :+stream-start+
+           :+stream-end+))
+(in-package :libyaml)
+
+(load-foreign-library
+  (namestring
+    (make-pathname :name "yaml_wrapper"
+                   :type #+unix "so" #+darwin "dylib" #+windows "dll"
+                   :defaults (asdf::component-relative-pathname
+                               (asdf:find-system :cl-yaml)))))
+
+(defcfun ("tokenize" tokenize) :pointer (str :string) (len :int))
+
+;; Accessors
+
+(defcfun ("list_len" list-len) :int (list :pointer))
+(defcfun ("nth_tok" nth-tok) :pointer (list :pointer) (n :int))
+(defcfun ("destroy_nth_tok" destroy-nth-tok) :void (list :pointer) (n :int))
+(defcfun ("list_err" list-err) :string (list :pointer))
+(defcfun ("tok_type" tok-type) :int (tok :pointer))
+(defcfun ("tok_value" tok-value) :string (tok :pointer))
+(defcfun ("tok_anchor" tok-anchor) :string (tok :pointer))
+
+(defcfun ("destroyTokenList" destroy-token-list) :void (list :pointer))
+
+;; Enum values
+
+(defcfun ("enum_scalar" enum-scalar) :int)
+(defcfun ("enum_alias" enum-alias) :int)
+(defcfun ("enum_seq_start" enum-seq-start) :int)
+(defcfun ("enum_seq_end" enum-seq-end) :int)
+(defcfun ("enum_map_start" enum-map-start) :int)
+(defcfun ("enum_map_end" enum-map-end) :int)
+(defcfun ("enum_doc_start" enum-doc-start) :int)
+(defcfun ("enum_doc_end" enum-doc-end) :int)
+(defcfun ("enum_stream_start" enum-stream-start) :int)
+(defcfun ("enum_stream_end" enum-stream-end) :int)
+
+(defparameter +enum+ (make-hash-table))
+
+(setf (gethash (enum-scalar) +enum+) :scalar)
+(setf (gethash (enum-alias) +enum+) :alias)
+(setf (gethash (enum-seq-start) +enum+) :seq-start)
+(setf (gethash (enum-seq-end) +enum+) :seq-end)
+(setf (gethash (enum-map-start) +enum+) :map-start)
+(setf (gethash (enum-map-end) +enum+) :map-end)
+(setf (gethash (enum-doc-start) +enum+) :doc-start)
+(setf (gethash (enum-doc-end) +enum+) :doc-end)
+(setf (gethash (enum-stream-start) +enum+) :stream-start)
+(setf (gethash (enum-stream-end) +enum+) :stream-end)
+
+(defparameter +scalar+ (enum-scalar))
+(defparameter +alias+ (enum-alias))
+(defparameter +seq-start+ (enum-seq-start))
+(defparameter +seq-end+ (enum-seq-end))
+(defparameter +map-start+ (enum-map-start))
+(defparameter +map-end+ (enum-map-end))
+(defparameter +doc-start+ (enum-doc-start))
+(defparameter +doc-end+ (enum-doc-end))
+(defparameter +stream-start+ (enum-stream-start))
+(defparameter +stream-end+ (enum-stream-end))