Yaml parser (#20)

* Complete a YAML parser

Unit test runner reimplemented from ground up.

* fix test failure recording

* code no longer derives from 'fiasco'

* restore toplevel script entry point

* require asdf

* ci test script

* handle error in test setup

* handle error in test setup

LICENSE

@@ -92,51 +92,6 @@ following license:
     SUCH DAMAGE.
 
 
-Portions of this code are derived from
-https://github.com/joaotavora/fiasco/, which is subject to the
-following license:
-
-    License
-    Fiasco is public domain software:
-
-      Authors dedicate this work to public domain, for the benefit of
-      the public at large and to the detriment of the authors' heirs
-      and successors. Authors intends this dedication to be an overt
-      act of relinquishment in perpetuity of all present and future
-      rights under copyright law, whether vested or contingent, in the
-      work. Authors understands that such relinquishment of all rights
-      includes the relinquishment of all rights to enforce (by lawsuit
-      or otherwise) those copyrights in the work.
-
-      Authors recognize that, once placed in the public domain, the
-      work may be freely reproduced, distributed, transmitted, used,
-      modified, built upon, or otherwise exploited by anyone for any
-      purpose, commercial or non-commercial, and in any way, including
-      by methods that have not yet been invented or conceived.
-
-    In those legislations where public domain dedications are not
-    recognized or possible, Fiasco is distributed under the following
-    terms and conditions:
-
-      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 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.
-
-
 Portions of this code are derived from
 https://github.com/sharplispers/ironclad/, which is subject to the
 following license:

epsilon.asd

@@ -3,7 +3,8 @@
 (asdf:defsystem "epsilon"
   :version "0.1.0"
   :description "A utility library for SBCL"
-  :depends-on (:sb-rotate-byte
+  :depends-on (:sb-posix
+               :sb-rotate-byte
                :sb-cltl2
                :sb-bsd-sockets
                :sb-rotate-byte)
@@ -17,9 +18,9 @@
                    (:file "array")
                    (:file "condition")
                    (:file "string")
+                   (:file "format")
                    (:file "function")
                    (:file "list")
-                   (:file "hash")
                    (:file "json")
                    (:file "collect")
                    (:file "control")
@@ -193,5 +194,5 @@
      (:module "net"
               :components ((:file "http-tests"))))))
   :perform (test-op (o c)
-                   (symbol-call :epsilon.tool.test ':run-all-tests)))
+                   (symbol-call :epsilon.tool.test ':run-tests)))
 

etc/test.lisp

@@ -0,0 +1,14 @@
+(require :asdf)
+
+(load "epsilon.asd")
+
+(handler-case
+    (asdf:load-system "epsilon/tests")
+  (error (condition)
+    (format *error-output "~A~%" condition)
+    (sb-debug:print-backtrace :stream *error-output*)))
+
+(sb-posix:exit (if (epsilon.tool.test:run-success-p (epsilon.tool.test:run-tests))
+                   0
+                   1))
+

make

@@ -0,0 +1,33 @@
+#!/usr/bin/env nu
+
+def build [] {
+    (sbcl --noinform
+          --non-interactive
+          --eval "(load \"epsilon.asd\")"
+          --eval "(asdf:load-system \"epsilon\" :force t)")
+}
+
+def test [] {
+    (sbcl --noinform
+          --non-interactive
+          --eval "(load \"etc/test.lisp\")")
+}
+
+def coverage [] {
+    mkdir target/coverage
+    (sbcl --noinform
+          --non-interactive
+          --eval "(require :sb-cover)"
+          --eval "(load \"epsilon.asd\" :force t)"
+          --eval "(asdf:test-system \"epsilon\")"
+          --eval "(sb-cover:report \"target/coverage/\")")
+    open target/coverage/cover-index.html
+}
+
+def main [args] {
+    match $args {
+        "build"    => build,
+        "test"     => test,
+        "coverage" => coverage
+    }
+}

src/lib/char/encoding/encoding.lisp

@@ -46,7 +46,7 @@
 encodings.  This list does not include aliases."
   *supported-character-encodings*)
 
-(defvar *character-encodings* (make-hash-table :test 'eq))
+(defvar *character-encodings* map:+empty+)
 
 (defvar *default-character-encoding* :utf-8
   "Special variable used to determine the default character
@@ -60,7 +60,7 @@ a CHARACTER-ENCONDING object, it is returned unmodified."
     (return-from get-character-encoding name))
   (when (eq name :default)
     (setq name *default-character-encoding*))
-  (or (gethash name *character-encodings*)
+  (or (map:map-get *character-encodings* name)
       (error "Unknown character encoding: ~S" name)))
 
 (defmethod ambiguous-encoding-p ((encoding symbol))
@@ -69,7 +69,8 @@ a CHARACTER-ENCONDING object, it is returned unmodified."
 (defun notice-character-encoding (enc)
   (pushnew (enc-name enc) *supported-character-encodings*)
   (dolist (kw (cons (enc-name enc) (enc-aliases enc)))
-    (setf (gethash kw *character-encodings*) enc))
+    (setf *character-encodings*
+          (map:map-assoc *character-encodings* kw enc)))
   (enc-name enc))
 
 (defmacro define-character-encoding (name docstring &body options)
@@ -121,13 +122,14 @@ a CHARACTER-ENCONDING object, it is returned unmodified."
    (octet-counter :accessor octet-counter)
    (code-point-counter :accessor code-point-counter)))
 
-(defparameter *abstract-mappings* (make-hash-table :test 'eq))
+(defparameter *abstract-mappings* map:+empty+)
 
 (defun get-abstract-mapping (encoding)
-  (gethash encoding *abstract-mappings*))
+  (map:map-get *abstract-mappings* encoding))
 
 (defun (setf get-abstract-mapping) (value encoding)
-  (setf (gethash encoding *abstract-mappings*) value))
+  (setf *abstract-mappings*
+        (map:map-assoc *abstract-mappings* encoding value)))
 
 (defun %register-mapping-part (encoding slot-name fn)
   (let ((mapping (get-abstract-mapping encoding)))
@@ -201,22 +203,22 @@ a CHARACTER-ENCONDING object, it is returned unmodified."
 ;;; then saved in their respective slots of the CONCRETE-MAPPING
 ;;; object.
 (defmacro instantiate-concrete-mappings
-    (&key (encodings (hash-table-keys *abstract-mappings*))
+    (&key (encodings (map::map-keys *abstract-mappings*))
      (optimize '((speed 3) (debug 0) (compilation-speed 0)))
      octet-seq-getter octet-seq-setter octet-seq-type
      code-point-seq-getter code-point-seq-setter code-point-seq-type
      (instantiate-decoders t))
-  `(let ((ht (make-hash-table :test 'eq)))
+  `(let ((ht map:+empty+))
      (declare (optimize ,@optimize)
               #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
      (flet ((notice-mapping (encoding-name cm)
               (let* ((encoding (get-character-encoding encoding-name))
                      (aliases (enc-aliases encoding)))
                 (dolist (kw (cons (enc-name encoding) aliases))
-                  (setf (gethash kw ht) cm)))))
+                  (setf ht (map:map-assoc ht kw cm))))))
        ,@(loop for encoding-name in encodings
                for encoding = (get-character-encoding encoding-name)
-               for am = (gethash encoding-name *abstract-mappings*)
+               for am = (map:map-get *abstract-mappings* encoding-name)
                collect
                `(let ((cm (make-instance 'concrete-mapping)))
                   (setf (encoder cm)

src/lib/char/external-format.lisp

@@ -43,18 +43,18 @@ explicitly given.  Depends on the OS the code is compiled on.")
        (eq (encoding-eol-style ef1) (encoding-eol-style ef2))))
 
 (declaim (inline lookup-mapping))
-(defun lookup-mapping (ht encoding)
-  "HT should be an hashtable created by
+(defun lookup-mapping (m encoding)
+  "M should be a map created by
 INSTANTIATE-CONCRETE-MAPPINGS. ENCODING should be either an
 external format, an encoding object or a keyword symbol
 denoting a character encoding name or one of its aliases."
   (or (etypecase encoding
         (keyword
-         (gethash encoding ht))
+         (map:map-get m encoding))
         (epsilon.lib.char::concrete-mapping
          encoding)
         (character-encoding
-         (gethash (enc-name encoding) ht))
+         (map:map-get m (enc-name encoding)))
         (encoding
-         (gethash (enc-name (encoding-encoding encoding)) ht)))
+         (map:map-get m (enc-name (encoding-encoding encoding)))))
       (error "~S is not a valid encoding designator" encoding)))

src/lib/char/package.lisp

@@ -3,10 +3,10 @@
    #:cl
    #:epsilon.lib.binding
    #:epsilon.lib.function
-   #:epsilon.lib.hash
    #:epsilon.lib.symbol
    #:epsilon.lib.type
    #:epsilon.lib.vector)
+  (:local-nicknames (#:map #:epsilon.lib.map))
   (:export
    #:*string-vector-mappings*
    ;; character encoding objects

src/lib/format.lisp

@@ -0,0 +1,32 @@
+(defpackage #:epsilon.lib.format
+  (:use #:cl #:sb-gray)
+  (:export #:format-output-stream
+           #:output-column))
+
+(in-package #:epsilon.lib.format)
+
+(defclass format-output-stream (fundamental-character-output-stream)
+  ((column :initform 0 :accessor output-column)
+   (understream :initarg :understream :initform (error "required!"))))
+
+(defmethod stream-write-sequence ((s format-output-stream) seq &optional start end)
+  "Write SEQ to stream S."
+  (let ((newline-pos (position #\Newline seq :from-end t)))
+    (when newline-pos
+      (setf (output-column s) (- (length seq) newline-pos 1))))
+  (write-sequence seq (slot-value s 'understream) :start start :end end))
+
+(defmethod stream-line-column ((s format-output-stream))
+  "Tell column number that stream S is currently at."
+  (output-column s))
+
+(defmethod stream-start-line-p ((s format-output-stream))
+  "Tell if stream S is already at start of fresh new line."
+  (zerop (output-column s)))
+
+(defmethod stream-write-char ((s format-output-stream) char)
+  "Write CHAR to stream S."
+  (if (char= char #\Newline)
+      (setf (output-column s) 0)
+      (incf (output-column s)))
+  (write-char char (slot-value s 'understream)))